diff --git a/.bzrignore b/.bzrignore index 382e883e8..e6f72a2a6 100644 --- a/.bzrignore +++ b/.bzrignore @@ -4366,3 +4366,2988 @@ ED/dbgbuild/bin/utils_c.c BRAMS/newbuild ED/i10dbgbuild new_regional +BRAMS/src/advc_mnt +BRAMS/build/bin/mem_mnt_advec.mod +ED/dbgbuild/bin/a3e0_mod.mod +ED/dbgbuild/bin/a3e1_mod.mod +ED/dbgbuild/bin/a3e2_mod.mod +ED/dbgbuild/bin/accum_mod.mod +ED/dbgbuild/bin/acnst_mod.mod +ED/dbgbuild/bin/adivb_mod.mod +ED/dbgbuild/bin/adjust_sfcw_properties_mod.mod +ED/dbgbuild/bin/adjust_topsoil_properties_mod.mod +ED/dbgbuild/bin/adjust_veg_properties_mod.mod +ED/dbgbuild/bin/ae0_mod.mod +ED/dbgbuild/bin/ae1m1_mod.mod +ED/dbgbuild/bin/ae1_mod.mod +ED/dbgbuild/bin/ae1p1_mod.mod +ED/dbgbuild/bin/ae1p1p1_mod.mod +ED/dbgbuild/bin/ae1t0_mod.mod +ED/dbgbuild/bin/ae1t0p1_mod.mod +ED/dbgbuild/bin/ae1t1_mod.mod +ED/dbgbuild/bin/ae1t1p1_mod.mod +ED/dbgbuild/bin/ae1tn1_mod.mod +ED/dbgbuild/bin/ae2_mod.mod +ED/dbgbuild/bin/ae3m3d0_mod.mod +ED/dbgbuild/bin/ae3m3_mod.mod +ED/dbgbuild/bin/ae3_mod.mod +ED/dbgbuild/bin/ae3p3_mod.mod +ED/dbgbuild/bin/ae3t0p3_mod.mod +ED/dbgbuild/bin/ae3t3_mod.mod +ED/dbgbuild/bin/ae3t3p3_mod.mod +ED/dbgbuild/bin/aen1_mod.mod +ED/dbgbuild/bin/aen3t0p3_mod.mod +ED/dbgbuild/bin/alebl_mod.mod +ED/dbgbuild/bin/allometry.mod +ED/dbgbuild/bin/angle_of_incid_mod.mod +ED/dbgbuild/bin/an_header.mod +ED/dbgbuild/bin/aone2_mod.mod +ED/dbgbuild/bin/aone3_mod.mod +ED/dbgbuild/bin/aone4_mod.mod +ED/dbgbuild/bin/aone5_mod.mod +ED/dbgbuild/bin/aone_mod.mod +ED/dbgbuild/bin/aonev_mod.mod +ED/dbgbuild/bin/apply_forestry_mod.mod +ED/dbgbuild/bin/array2xcol_mod.mod +ED/dbgbuild/bin/array2ycol_mod.mod +ED/dbgbuild/bin/array2zcol_mod.mod +ED/dbgbuild/bin/assign_prescribed_phen_mod.mod +ED/dbgbuild/bin/atimb_mod.mod +ED/dbgbuild/bin/atob_log_mod.mod +ED/dbgbuild/bin/atob_mod.mod +ED/dbgbuild/bin/avg_ed_daily_output_pool_mod.mod +ED/dbgbuild/bin/azero2_mod.mod +ED/dbgbuild/bin/azero3_mod.mod +ED/dbgbuild/bin/azero4_mod.mod +ED/dbgbuild/bin/azero5_mod.mod +ED/dbgbuild/bin/azero_mod.mod +ED/dbgbuild/bin/azerov_mod.mod +ED/dbgbuild/bin/banbks_mod.mod +ED/dbgbuild/bin/bandec_mod.mod +ED/dbgbuild/bin/bdf2_solver_mod.mod +ED/dbgbuild/bin/c34constants.mod +ED/dbgbuild/bin/calc_flow_routing_mod.mod +ED/dbgbuild/bin/calchydrosubsurface_mod.mod +ED/dbgbuild/bin/calchydrosurface_mod.mod +ED/dbgbuild/bin/calc_met_lapse_mod.mod +ED/dbgbuild/bin/calcwatertable_mod.mod +ED/dbgbuild/bin/canopy_air_coms.mod +ED/dbgbuild/bin/canopy_derivs_two_mod.mod +ED/dbgbuild/bin/canopy_layer_coms.mod +ED/dbgbuild/bin/canopy_photosynthesis_mod.mod +ED/dbgbuild/bin/canopy_radiation_coms.mod +ED/dbgbuild/bin/canopy_struct_dynamics.mod +ED/dbgbuild/bin/cbrt8_mod.mod +ED/dbgbuild/bin/cbrt_mod.mod +ED/dbgbuild/bin/cdf2normal_mod.mod +ED/dbgbuild/bin/cdf_mod.mod +ED/dbgbuild/bin/char_strip_var_mod.mod +ED/dbgbuild/bin/check_real_mod.mod +ED/dbgbuild/bin/compute_budget_mod.mod +ED/dbgbuild/bin/compute_c_and_n_storage_mod.mod +ED/dbgbuild/bin/compute_co2_storage_mod.mod +ED/dbgbuild/bin/compute_energy_storage_mod.mod +ED/dbgbuild/bin/compute_netrad_mod.mod +ED/dbgbuild/bin/compute_water_storage_mod.mod +ED/dbgbuild/bin/consts_coms.mod +ED/dbgbuild/bin/copy_bdf2_prev_mod.mod +ED/dbgbuild/bin/copy_fb_patch_mod.mod +ED/dbgbuild/bin/copy_initp2prev_mod.mod +ED/dbgbuild/bin/copy_met_2_rk4site_mod.mod +ED/dbgbuild/bin/copy_nl_mod.mod +ED/dbgbuild/bin/copy_patch_init_carbon_mod.mod +ED/dbgbuild/bin/copy_patch_init_mod.mod +ED/dbgbuild/bin/copy_path_from_grid_1_mod.mod +ED/dbgbuild/bin/copy_prev2patch_mod.mod +ED/dbgbuild/bin/copy_rk4_patch_mod.mod +ED/dbgbuild/bin/count_pft_xml_config_mod.mod +ED/dbgbuild/bin/cputime_mod.mod +ED/dbgbuild/bin/create_ed10_ed20_fname_mod.mod +ED/dbgbuild/bin/cumsum_mod.mod +ED/dbgbuild/bin/cvmgm_mod.mod +ED/dbgbuild/bin/cvmgn_mod.mod +ED/dbgbuild/bin/cvmgp_mod.mod +ED/dbgbuild/bin/cvmgz_mod.mod +ED/dbgbuild/bin/date_2_seconds_mod.mod +ED/dbgbuild/bin/date_abs_secs2_mod.mod +ED/dbgbuild/bin/date_add_to_mod.mod +ED/dbgbuild/bin/date_secs_ymdt_mod.mod +ED/dbgbuild/bin/date_unmake_big_mod.mod +ED/dbgbuild/bin/daylength_mod.mod +ED/dbgbuild/bin/dcvmgm_mod.mod +ED/dbgbuild/bin/dcvmgp_mod.mod +ED/dbgbuild/bin/dcw_swap16_mod.mod +ED/dbgbuild/bin/dcw_swap32_mod.mod +ED/dbgbuild/bin/dcw_swap64_mod.mod +ED/dbgbuild/bin/ddens_dt_effect_mod.mod +ED/dbgbuild/bin/deblank_mod.mod +ED/dbgbuild/bin/decomp_coms.mod +ED/dbgbuild/bin/detab_mod.mod +ED/dbgbuild/bin/detailed_coms.mod +ED/dbgbuild/bin/diagon_mod.mod +ED/dbgbuild/bin/dist_gc_mod.mod +ED/dbgbuild/bin/disturbance_utils.mod +ED/dbgbuild/bin/disturb_coms.mod +ED/dbgbuild/bin/dmax2_mod.mod +ED/dbgbuild/bin/dmin2_mod.mod +ED/dbgbuild/bin/dssum_mod.mod +ED/dbgbuild/bin/dump_radinfo_mod.mod +ED/dbgbuild/bin/ed1_fileinfo_mod.mod +ED/dbgbuild/bin/ed_1st_master_mod.mod +ED/dbgbuild/bin/ed_1st_node_mod.mod +ED/dbgbuild/bin/ed21_fileinfo_mod.mod +ED/dbgbuild/bin/ed_datp_datq_mod.mod +ED/dbgbuild/bin/ed_datp_datsoil_mod.mod +ED/dbgbuild/bin/ed_driver_mod.mod +ED/dbgbuild/bin/ed_filelist_mod.mod +ED/dbgbuild/bin/ed_gridset_mod.mod +ED/dbgbuild/bin/ed_init_atm_mod.mod +ED/dbgbuild/bin/ed_ll_xy_mod.mod +ED/dbgbuild/bin/ed_load_work_from_history_mod.mod +ED/dbgbuild/bin/ed_masterput_met_header_mod.mod +ED/dbgbuild/bin/ed_masterput_nl_mod.mod +ED/dbgbuild/bin/ed_masterput_poly_dims_mod.mod +ED/dbgbuild/bin/ed_masterput_processid_mod.mod +ED/dbgbuild/bin/ed_masterput_worklist_info_mod.mod +ED/dbgbuild/bin/ed_max_dims.mod +ED/dbgbuild/bin/ed_mem_alloc_mod.mod +ED/dbgbuild/bin/ed_mem_grid_dim_defs.mod +ED/dbgbuild/bin/ed_misc_coms.mod +ED/dbgbuild/bin/ed_model_mod.mod +ED/dbgbuild/bin/ed_newgrid_mod.mod +ED/dbgbuild/bin/ed_node_coms.mod +ED/dbgbuild/bin/ed_node_decomp_mod.mod +ED/dbgbuild/bin/ed_nodeget_met_header_mod.mod +ED/dbgbuild/bin/ed_nodeget_nl_mod.mod +ED/dbgbuild/bin/ed_nodeget_poly_dims_mod.mod +ED/dbgbuild/bin/ed_nodeget_processid_mod.mod +ED/dbgbuild/bin/ed_nodeget_worklist_info_mod.mod +ED/dbgbuild/bin/ed_opspec_grid_mod.mod +ED/dbgbuild/bin/ed_opspec_misc_mod.mod +ED/dbgbuild/bin/ed_opspec_par_mod.mod +ED/dbgbuild/bin/ed_opspec_times_mod.mod +ED/dbgbuild/bin/ed_output_mod.mod +ED/dbgbuild/bin/ed_para_coms.mod +ED/dbgbuild/bin/ed_parvec_work_mod.mod +ED/dbgbuild/bin/ed_polarst_mod.mod +ED/dbgbuild/bin/ed_state_vars.mod +ED/dbgbuild/bin/ed_therm_lib.mod +ED/dbgbuild/bin/ed_var_tables.mod +ED/dbgbuild/bin/ed_work_vars.mod +ED/dbgbuild/bin/ed_xy_ll_mod.mod +ED/dbgbuild/bin/ed_zen_mod.mod +ED/dbgbuild/bin/eifun8_mod.mod +ED/dbgbuild/bin/elgs_mod.mod +ED/dbgbuild/bin/ename_coms.mod +ED/dbgbuild/bin/endian_mod.mod +ED/dbgbuild/bin/errorfun_mod.mod +ED/dbgbuild/bin/euler_integ_mod.mod +ED/dbgbuild/bin/euler_timestep_mod.mod +ED/dbgbuild/bin/event_fertilize_mod.mod +ED/dbgbuild/bin/event_fire_mod.mod +ED/dbgbuild/bin/event_harvest_mod.mod +ED/dbgbuild/bin/event_irrigate_mod.mod +ED/dbgbuild/bin/event_planting_mod.mod +ED/dbgbuild/bin/event_till_mod.mod +ED/dbgbuild/bin/expected_mod.mod +ED/dbgbuild/bin/expmsq_mod.mod +ED/dbgbuild/bin/exterminate_patches_except_mod.mod +ED/dbgbuild/bin/fail_whale_mod.mod +ED/dbgbuild/bin/farq_leuning.mod +ED/dbgbuild/bin/fatal_error_mod.mod +ED/dbgbuild/bin/fb_dy_step_trunc_mod.mod +ED/dbgbuild/bin/fb_sanity_check_mod.mod +ED/dbgbuild/bin/fill_history_grid_mod.mod +ED/dbgbuild/bin/fill_history_patch_mod.mod +ED/dbgbuild/bin/fill_history_polygon_mod.mod +ED/dbgbuild/bin/fill_history_site_mod.mod +ED/dbgbuild/bin/fillvar_l_mod.mod +ED/dbgbuild/bin/find_closing_comment_mod.mod +ED/dbgbuild/bin/find_frqsum_mod.mod +ED/dbgbuild/bin/findln_mod.mod +ED/dbgbuild/bin/find_rank_mod.mod +ED/dbgbuild/bin/fire_frequency_mod.mod +ED/dbgbuild/bin/first_phenology_mod.mod +ED/dbgbuild/bin/flag_stable_cohorts_mod.mod +ED/dbgbuild/bin/fuse_fiss_utils.mod +ED/dbgbuild/bin/fusion_fission_coms.mod +ED/dbgbuild/bin/getconfigint_mod.mod +ED/dbgbuild/bin/getconfigreal_mod.mod +ED/dbgbuild/bin/getconfigstring_mod.mod +ED/dbgbuild/bin/get_errmax_mod.mod +ED/dbgbuild/bin/get_file_indices_mod.mod +ED/dbgbuild/bin/get_grid_mod.mod +ED/dbgbuild/bin/geth5dims_mod.mod +ED/dbgbuild/bin/getll_mod.mod +ED/dbgbuild/bin/get_work_mod.mod +ED/dbgbuild/bin/get_yscal_mod.mod +ED/dbgbuild/bin/grid_coms.mod +ED/dbgbuild/bin/growth_balive.mod +ED/dbgbuild/bin/h5_output_mod.mod +ED/dbgbuild/bin/harv_immat_patches_mod.mod +ED/dbgbuild/bin/harv_mat_patches_mod.mod +ED/dbgbuild/bin/hdf5_coms.mod +ED/dbgbuild/bin/hdf5_utils.mod +ED/dbgbuild/bin/hdf_getslab_d_mod.mod +ED/dbgbuild/bin/hdf_getslab_i_mod.mod +ED/dbgbuild/bin/hdf_getslab_r_mod.mod +ED/dbgbuild/bin/heav_mod.mod +ED/dbgbuild/bin/het_resp_weight_mod.mod +ED/dbgbuild/bin/heun_integ_mod.mod +ED/dbgbuild/bin/heun_stepper_mod.mod +ED/dbgbuild/bin/heun_timestep_mod.mod +ED/dbgbuild/bin/how_to_read_a_file_mod.mod +ED/dbgbuild/bin/hybrid_integ_mod.mod +ED/dbgbuild/bin/hybrid_timestep_mod.mod +ED/dbgbuild/bin/hydrology_coms.mod +ED/dbgbuild/bin/hydrology_constants.mod +ED/dbgbuild/bin/ibias_mod.mod +ED/dbgbuild/bin/ibindec_mod.mod +ED/dbgbuild/bin/ifirstchar_mod.mod +ED/dbgbuild/bin/inc_fwd_patch_mod.mod +ED/dbgbuild/bin/inc_rk4_patch_mod.mod +ED/dbgbuild/bin/init_can_air_params_mod.mod +ED/dbgbuild/bin/init_can_lyr_params_mod.mod +ED/dbgbuild/bin/init_can_rad_params_mod.mod +ED/dbgbuild/bin/init_cohorts_by_layers_mod.mod +ED/dbgbuild/bin/init_decomp_params_mod.mod +ED/dbgbuild/bin/init_disturb_params_mod.mod +ED/dbgbuild/bin/init_ed_cohort_vars_mod.mod +ED/dbgbuild/bin/init_ed_misc_coms_mod.mod +ED/dbgbuild/bin/init_ed_patch_vars_mod.mod +ED/dbgbuild/bin/init_ed_poly_vars_mod.mod +ED/dbgbuild/bin/init_ed_site_vars_mod.mod +ED/dbgbuild/bin/init_ff_coms_mod.mod +ED/dbgbuild/bin/init_full_history_restart_mod.mod +ED/dbgbuild/bin/init_hydro_coms_mod.mod +ED/dbgbuild/bin/inithydrology_mod.mod +ED/dbgbuild/bin/inithydrosubsurface_mod.mod +ED/dbgbuild/bin/initialize_rk4patches_mod.mod +ED/dbgbuild/bin/init_lapse_params_mod.mod +ED/dbgbuild/bin/init_met_drivers_mod.mod +ED/dbgbuild/bin/init_met_params_mod.mod +ED/dbgbuild/bin/init_nbg_cohorts_mod.mod +ED/dbgbuild/bin/init_pft_alloc_params_mod.mod +ED/dbgbuild/bin/init_pft_derived_params_mod.mod +ED/dbgbuild/bin/init_pft_leaf_params_mod.mod +ED/dbgbuild/bin/init_pft_mort_params_mod.mod +ED/dbgbuild/bin/init_pft_nitro_params_mod.mod +ED/dbgbuild/bin/init_pft_photo_params_mod.mod +ED/dbgbuild/bin/init_pft_repro_params_mod.mod +ED/dbgbuild/bin/init_pft_resp_params_mod.mod +ED/dbgbuild/bin/init_phen_coms_mod.mod +ED/dbgbuild/bin/init_physiology_params_mod.mod +ED/dbgbuild/bin/init_rk4_params_mod.mod +ED/dbgbuild/bin/init_soil_coms_mod.mod +ED/dbgbuild/bin/integrate_ed_daily_output_flux_mod.mod +ED/dbgbuild/bin/integrate_ed_daily_output_state_mod.mod +ED/dbgbuild/bin/integrate_ed_monthly_output_vars_mod.mod +ED/dbgbuild/bin/integrate_patch_euler_mod.mod +ED/dbgbuild/bin/integrate_patch_heun_mod.mod +ED/dbgbuild/bin/int_met_avg_mod.mod +ED/dbgbuild/bin/inventory_mat_forests_mod.mod +ED/dbgbuild/bin/iprim_mod.mod +ED/dbgbuild/bin/iran_recsize_mod.mod +ED/dbgbuild/bin/is_finite8_mod.mod +ED/dbgbuild/bin/is_finite_mod.mod +ED/dbgbuild/bin/isleap_mod.mod +ED/dbgbuild/bin/ismax_mod.mod +ED/dbgbuild/bin/ismin_mod.mod +ED/dbgbuild/bin/is_resolvable_mod.mod +ED/dbgbuild/bin/ivalugp_mod.mod +ED/dbgbuild/bin/izero2_mod.mod +ED/dbgbuild/bin/izero3_mod.mod +ED/dbgbuild/bin/izero4_mod.mod +ED/dbgbuild/bin/izero5_mod.mod +ED/dbgbuild/bin/izero_mod.mod +ED/dbgbuild/bin/izerov_mod.mod +ED/dbgbuild/bin/julday1000_mod.mod +ED/dbgbuild/bin/julday_mod.mod +ED/dbgbuild/bin/landuse_init_mod.mod +ED/dbgbuild/bin/large_error_mod.mod +ED/dbgbuild/bin/lastchar_mod.mod +ED/dbgbuild/bin/lastmonthdate_mod.mod +ED/dbgbuild/bin/lastslash_mod.mod +ED/dbgbuild/bin/leaf_database_mod.mod +ED/dbgbuild/bin/leaf_derivs_mod.mod +ED/dbgbuild/bin/leaftw_derivs_mod.mod +ED/dbgbuild/bin/libxml2f90__closeall_mod.mod +ED/dbgbuild/bin/libxml2f90__closefile_mod.mod +ED/dbgbuild/bin/libxml2f90_error_getline_mod.mod +ED/dbgbuild/bin/libxml2f90__existid_mod.mod +ED/dbgbuild/bin/libxml2f90_existid_mod.mod +ED/dbgbuild/bin/libxml2f90__existpid_mod.mod +ED/dbgbuild/bin/libxml2f90__findinchara_mod.mod +ED/dbgbuild/bin/libxml2f90__flush_mod.mod +ED/dbgbuild/bin/libxml2f90__get_fileunit_mod.mod +ED/dbgbuild/bin/libxml2f90_getline_mod.mod +ED/dbgbuild/bin/libxml2f90_getsafec8_mod.mod +ED/dbgbuild/bin/libxml2f90_getsafei4_mod.mod +ED/dbgbuild/bin/libxml2f90_getsafel4_mod.mod +ED/dbgbuild/bin/libxml2f90_getsafer8_mod.mod +ED/dbgbuild/bin/libxml2f90__getunit_mod.mod +ED/dbgbuild/bin/libxml2f90_interface_module.mod +ED/dbgbuild/bin/libxml2f90__ll_addid_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_addid_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_add_list_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_add_list_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_addpid_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_addpid_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_addpureid_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_closetag_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_closetag_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_down_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_edit_id_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_edit_id_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_edit_pid_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_edit_pid_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_exist_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getc8__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getc8_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_getc8_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getch_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_getch_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getch_scal_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_geti4__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_geti4_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_geti4_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getl4__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getl4_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_getl4_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpc8__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpc8_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpch_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpi4__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpi4_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpl4__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpl4_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpr8__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpr8_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpsize_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpstring__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpstring_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getr8__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getr8_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_getr8_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getsize_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_getsize_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getstring__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getstring_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_getstring_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_initlist_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_inittag_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_opentag_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_opentag_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_report_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_report_rec_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_report_rec_wrap_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_selectlist_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_selecttag_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_up_mod.mod +ED/dbgbuild/bin/libxml2f90_module.mod +ED/dbgbuild/bin/libxml2f90__openfile_mod.mod +ED/dbgbuild/bin/libxml2f90_parse_file_mod.mod +ED/dbgbuild/bin/libxml2f90_parse_find_char_mod.mod +ED/dbgbuild/bin/libxml2f90__readin_file_mod.mod +ED/dbgbuild/bin/libxml2f90_readin_file_mod.mod +ED/dbgbuild/bin/libxml2f90__readin_nfil_mod.mod +ED/dbgbuild/bin/libxml2f90__set_casesensitive_mod.mod +ED/dbgbuild/bin/libxml2f90__set_default_ll_id_mod.mod +ED/dbgbuild/bin/libxml2f90__setformat_mod.mod +ED/dbgbuild/bin/libxml2f90__set_paw_mod.mod +ED/dbgbuild/bin/libxml2f90__set_rmcomma_mod.mod +ED/dbgbuild/bin/libxml2f90__set_rmquotes_mod.mod +ED/dbgbuild/bin/libxml2f90__settransform_exm_mod.mod +ED/dbgbuild/bin/libxml2f90__setwrite_exm_mod.mod +ED/dbgbuild/bin/libxml2f90_strings_module.mod +ED/dbgbuild/bin/libxml2f90_tostringa_mod.mod +ED/dbgbuild/bin/libxml2f90_tostring_mod.mod +ED/dbgbuild/bin/libxml2f90_transform_paw_mod.mod +ED/dbgbuild/bin/lisys_solver8_mod.mod +ED/dbgbuild/bin/lisys_solver_mod.mod +ED/dbgbuild/bin/ll_module.mod +ED/dbgbuild/bin/load_ecosystem_state_mod.mod +ED/dbgbuild/bin/load_ed_ecosystem_params_mod.mod +ED/dbgbuild/bin/lubksb_dble_mod.mod +ED/dbgbuild/bin/ludcmp_dble_mod.mod +ED/dbgbuild/bin/lw_multiple_scatter_mod.mod +ED/dbgbuild/bin/lw_twostream_mod.mod +ED/dbgbuild/bin/makefnam_mod.mod +ED/dbgbuild/bin/match_poly_grid_mod.mod +ED/dbgbuild/bin/mat_forest_harv_rates_mod.mod +ED/dbgbuild/bin/mean_daysecz_mod.mod +ED/dbgbuild/bin/mem_polygons.mod +ED/dbgbuild/bin/met_driver_coms.mod +ED/dbgbuild/bin/met_sanity_check_mod.mod +ED/dbgbuild/bin/migs_mod.mod +ED/dbgbuild/bin/mk_2_buff_mod.mod +ED/dbgbuild/bin/mk_2p_buff_mod.mod +ED/dbgbuild/bin/mk_3_buff_mod.mod +ED/dbgbuild/bin/mk_4_buff_mod.mod +ED/dbgbuild/bin/mortality.mod +ED/dbgbuild/bin/mprove_mod.mod +ED/dbgbuild/bin/near_bare_ground_big_leaf_init_mod.mod +ED/dbgbuild/bin/near_bare_ground_init_mod.mod +ED/dbgbuild/bin/new_patch_sfc_props_mod.mod +ED/dbgbuild/bin/normalize_averaged_vars_mod.mod +ED/dbgbuild/bin/normalize_ed_dailynpp_vars_mod.mod +ED/dbgbuild/bin/normalize_ed_daily_output_vars_mod.mod +ED/dbgbuild/bin/normalize_ed_daily_vars_mod.mod +ED/dbgbuild/bin/normalize_ed_monthly_output_vars_mod.mod +ED/dbgbuild/bin/norm_harv_patch_mod.mod +ED/dbgbuild/bin/num_days_mod.mod +ED/dbgbuild/bin/odeint_mod.mod +ED/dbgbuild/bin/opspec_fatal_mod.mod +ED/dbgbuild/bin/optimiz_coms.mod +ED/dbgbuild/bin/overwrite_with_xml_config_mod.mod +ED/dbgbuild/bin/parsefnam_mod.mod +ED/dbgbuild/bin/parse_mod.mod +ED/dbgbuild/bin/pft_coms.mod +ED/dbgbuild/bin/pheninit_balive_bstorage_mod.mod +ED/dbgbuild/bin/phenology_coms.mod +ED/dbgbuild/bin/phenology_driver_eq_0_mod.mod +ED/dbgbuild/bin/phenology_driver_mod.mod +ED/dbgbuild/bin/phenology_startup.mod +ED/dbgbuild/bin/phenology_thresholds_mod.mod +ED/dbgbuild/bin/physiology_coms.mod +ED/dbgbuild/bin/plant_structural_allocation_mod.mod +ED/dbgbuild/bin/prescribed_event_mod.mod +ED/dbgbuild/bin/prescribed_leaf_state_mod.mod +ED/dbgbuild/bin/print_c_and_n_budgets_mod.mod +ED/dbgbuild/bin/print_csiteipa_mod.mod +ED/dbgbuild/bin/print_errmax_mod.mod +ED/dbgbuild/bin/print_fields_mod.mod +ED/dbgbuild/bin/print_photo_details_mod.mod +ED/dbgbuild/bin/print_rk4patch_mod.mod +ED/dbgbuild/bin/print_rk4_state_mod.mod +ED/dbgbuild/bin/print_soil_info_mod.mod +ED/dbgbuild/bin/putconfigint_mod.mod +ED/dbgbuild/bin/putconfigreal8_mod.mod +ED/dbgbuild/bin/putconfigreal_mod.mod +ED/dbgbuild/bin/putconfigstring_mod.mod +ED/dbgbuild/bin/radiate_driver_mod.mod +ED/dbgbuild/bin/rams_f_open_mod.mod +ED/dbgbuild/bin/rank_down_mod.mod +ED/dbgbuild/bin/rank_up_mod.mod +ED/dbgbuild/bin/read_ed10_ed20_history_file_mod.mod +ED/dbgbuild/bin/read_ed21_history_file_mod.mod +ED/dbgbuild/bin/read_ed21_history_unstruct_mod.mod +ED/dbgbuild/bin/read_ed_xml_config_mod.mod +ED/dbgbuild/bin/read_events_xml_mod.mod +ED/dbgbuild/bin/read_met_driver_head_mod.mod +ED/dbgbuild/bin/read_met_drivers_init_mod.mod +ED/dbgbuild/bin/read_met_drivers_mod.mod +ED/dbgbuild/bin/read_nl_mod.mod +ED/dbgbuild/bin/read_ol_file_mod.mod +ED/dbgbuild/bin/read_plantation_fractions_mod.mod +ED/dbgbuild/bin/read_site_file_mod.mod +ED/dbgbuild/bin/read_soil_depth_mod.mod +ED/dbgbuild/bin/read_soil_moist_temp_mod.mod +ED/dbgbuild/bin/rearrange_mod.mod +ED/dbgbuild/bin/reproduction_eq_0_mod.mod +ED/dbgbuild/bin/reproduction_mod.mod +ED/dbgbuild/bin/reset_averaged_vars_mod.mod +ED/dbgbuild/bin/resp_f_decomp_mod.mod +ED/dbgbuild/bin/resp_rh_mod.mod +ED/dbgbuild/bin/rk4_coms.mod +ED/dbgbuild/bin/rk4_driver.mod +ED/dbgbuild/bin/rk4_stepper.mod +ED/dbgbuild/bin/root_resp_norm_mod.mod +ED/dbgbuild/bin/scale_ed_radiation_mod.mod +ED/dbgbuild/bin/seed_dispersal_mod.mod +ED/dbgbuild/bin/selective_gaussian_2body_mod.mod +ED/dbgbuild/bin/setlapseparms_mod.mod +ED/dbgbuild/bin/set_polygon_coordinates_mod.mod +ED/dbgbuild/bin/set_site_defprops_mod.mod +ED/dbgbuild/bin/sfcdata_ed_mod.mod +ED/dbgbuild/bin/sfcrad_ed_mod.mod +ED/dbgbuild/bin/short2diff_sib_mod.mod +ED/dbgbuild/bin/short_bdown_weissnorman_mod.mod +ED/dbgbuild/bin/sngloff_mod.mod +ED/dbgbuild/bin/soil_coms.mod +ED/dbgbuild/bin/soil_depth_fill_mod.mod +ED/dbgbuild/bin/soil_respiration_mod.mod +ED/dbgbuild/bin/solar_radiation_breakdown_mod.mod +ED/dbgbuild/bin/sort3_mod.mod +ED/dbgbuild/bin/sort_down_mod.mod +ED/dbgbuild/bin/sort_up_mod.mod +ED/dbgbuild/bin/spatial_averages_mod.mod +ED/dbgbuild/bin/ssum_mod.mod +ED/dbgbuild/bin/structural_growth_eq_0_mod.mod +ED/dbgbuild/bin/structural_growth_mod.mod +ED/dbgbuild/bin/sum_plant_cfluxes_mod.mod +ED/dbgbuild/bin/sw_multiple_scatter_mod.mod +ED/dbgbuild/bin/sw_twostream_clump_mod.mod +ED/dbgbuild/bin/test_mod.mod +ED/dbgbuild/bin/therm_lib8.mod +ED/dbgbuild/bin/therm_lib.mod +ED/dbgbuild/bin/timing_mod.mod +ED/dbgbuild/bin/tokenize1_mod.mod +ED/dbgbuild/bin/tolower_mod.mod +ED/dbgbuild/bin/transfer_ol_month_mod.mod +ED/dbgbuild/bin/trid2_mod.mod +ED/dbgbuild/bin/trid_mod.mod +ED/dbgbuild/bin/ugetarg_mod.mod +ED/dbgbuild/bin/unarrange_mod.mod +ED/dbgbuild/bin/update_budget_mod.mod +ED/dbgbuild/bin/update_c_and_n_pools_mod.mod +ED/dbgbuild/bin/update_derived_cohort_props_mod.mod +ED/dbgbuild/bin/update_derived_props_mod.mod +ED/dbgbuild/bin/update_diagnostic_vars_mod.mod +ED/dbgbuild/bin/update_ed_yearly_vars_mod.mod +ED/dbgbuild/bin/updatehydroparms_mod.mod +ED/dbgbuild/bin/update_met_drivers_mod.mod +ED/dbgbuild/bin/update_model_time_dm_mod.mod +ED/dbgbuild/bin/update_mod.mod +ED/dbgbuild/bin/update_patch_derived_props_mod.mod +ED/dbgbuild/bin/update_patch_thermo_props_mod.mod +ED/dbgbuild/bin/update_phenology_eq_0_mod.mod +ED/dbgbuild/bin/update_phenology_mod.mod +ED/dbgbuild/bin/update_polygon_derived_props_mod.mod +ED/dbgbuild/bin/update_rad_avg_mod.mod +ED/dbgbuild/bin/update_site_derived_props_mod.mod +ED/dbgbuild/bin/update_thermal_sums_mod.mod +ED/dbgbuild/bin/update_turnover_mod.mod +ED/dbgbuild/bin/update_vital_rates_mod.mod +ED/dbgbuild/bin/updatewatertableadd_mod.mod +ED/dbgbuild/bin/updatewatertablebaseflow_mod.mod +ED/dbgbuild/bin/updatewatertablesubtract_mod.mod +ED/dbgbuild/bin/update_workload_mod.mod +ED/dbgbuild/bin/valugp_mod.mod +ED/dbgbuild/bin/vegetation_dynamics_eq_0_mod.mod +ED/dbgbuild/bin/vegetation_dynamics_mod.mod +ED/dbgbuild/bin/walltime_mod.mod +ED/dbgbuild/bin/warning_mod.mod +ED/dbgbuild/bin/write_ed_xml_config_mod.mod +ED/dbgbuild/bin/writehydro_mod.mod +ED/dbgbuild/bin/xcol2array_mod.mod +ED/dbgbuild/bin/ycol2array_mod.mod +ED/dbgbuild/bin/yesterday_mod.mod +ED/dbgbuild/bin/zcol2array_mod.mod +ED/dbgbuild/bin/zero_ed_daily_output_vars_mod.mod +ED/dbgbuild/bin/zero_ed_daily_vars_mod.mod +ED/dbgbuild/bin/zero_ed_monthly_output_vars_mod.mod +ED/dbgbuild/bin/zero_ed_yearly_vars_mod.mod +ED/dbgbuild/bin/a3e0_mod.f90 +ED/dbgbuild/bin/a3e1_mod.f90 +ED/dbgbuild/bin/a3e2_mod.f90 +ED/dbgbuild/bin/accum_mod.f90 +ED/dbgbuild/bin/acnst_mod.f90 +ED/dbgbuild/bin/adivb_mod.f90 +ED/dbgbuild/bin/adjust_sfcw_properties_mod.f90 +ED/dbgbuild/bin/adjust_topsoil_properties_mod.f90 +ED/dbgbuild/bin/adjust_veg_properties_mod.f90 +ED/dbgbuild/bin/ae0_mod.f90 +ED/dbgbuild/bin/ae1m1_mod.f90 +ED/dbgbuild/bin/ae1_mod.f90 +ED/dbgbuild/bin/ae1p1_mod.f90 +ED/dbgbuild/bin/ae1p1p1_mod.f90 +ED/dbgbuild/bin/ae1t0_mod.f90 +ED/dbgbuild/bin/ae1t0p1_mod.f90 +ED/dbgbuild/bin/ae1t1_mod.f90 +ED/dbgbuild/bin/ae1t1p1_mod.f90 +ED/dbgbuild/bin/ae1tn1_mod.f90 +ED/dbgbuild/bin/ae2_mod.f90 +ED/dbgbuild/bin/ae3m3d0_mod.f90 +ED/dbgbuild/bin/ae3m3_mod.f90 +ED/dbgbuild/bin/ae3_mod.f90 +ED/dbgbuild/bin/ae3p3_mod.f90 +ED/dbgbuild/bin/ae3t0p3_mod.f90 +ED/dbgbuild/bin/ae3t3_mod.f90 +ED/dbgbuild/bin/ae3t3p3_mod.f90 +ED/dbgbuild/bin/aen1_mod.f90 +ED/dbgbuild/bin/aen3t0p3_mod.f90 +ED/dbgbuild/bin/alebl_mod.f90 +ED/dbgbuild/bin/allometry.f90 +ED/dbgbuild/bin/angle_of_incid_mod.f90 +ED/dbgbuild/bin/an_header.f90 +ED/dbgbuild/bin/aone2_mod.f90 +ED/dbgbuild/bin/aone3_mod.f90 +ED/dbgbuild/bin/aone4_mod.f90 +ED/dbgbuild/bin/aone5_mod.f90 +ED/dbgbuild/bin/aone_mod.f90 +ED/dbgbuild/bin/aonev_mod.f90 +ED/dbgbuild/bin/apply_forestry_mod.f90 +ED/dbgbuild/bin/array2xcol_mod.f90 +ED/dbgbuild/bin/array2ycol_mod.f90 +ED/dbgbuild/bin/array2zcol_mod.f90 +ED/dbgbuild/bin/assign_prescribed_phen_mod.f90 +ED/dbgbuild/bin/atimb_mod.f90 +ED/dbgbuild/bin/atob_log_mod.f90 +ED/dbgbuild/bin/atob_mod.f90 +ED/dbgbuild/bin/average_utils.f90 +ED/dbgbuild/bin/avg_ed_daily_output_pool_mod.f90 +ED/dbgbuild/bin/azero2_mod.f90 +ED/dbgbuild/bin/azero3_mod.f90 +ED/dbgbuild/bin/azero4_mod.f90 +ED/dbgbuild/bin/azero5_mod.f90 +ED/dbgbuild/bin/azero_mod.f90 +ED/dbgbuild/bin/azerov_mod.f90 +ED/dbgbuild/bin/banbks_mod.f90 +ED/dbgbuild/bin/bandec_mod.f90 +ED/dbgbuild/bin/bdf2_solver.f90 +ED/dbgbuild/bin/bdf2_solver_mod.f90 +ED/dbgbuild/bin/budget_utils.f90 +ED/dbgbuild/bin/c34constants.f90 +ED/dbgbuild/bin/calc_flow_routing_mod.f90 +ED/dbgbuild/bin/calchydrosubsurface_mod.f90 +ED/dbgbuild/bin/calchydrosurface_mod.f90 +ED/dbgbuild/bin/calc_met_lapse_mod.f90 +ED/dbgbuild/bin/calcwatertable_mod.f90 +ED/dbgbuild/bin/canopy_air_coms.f90 +ED/dbgbuild/bin/canopy_derivs_two_mod.f90 +ED/dbgbuild/bin/canopy_layer_coms.f90 +ED/dbgbuild/bin/canopy_photosynthesis_mod.f90 +ED/dbgbuild/bin/canopy_radiation_coms.f90 +ED/dbgbuild/bin/canopy_struct_dynamics.f90 +ED/dbgbuild/bin/cbrt8_mod.f90 +ED/dbgbuild/bin/cbrt_mod.f90 +ED/dbgbuild/bin/cdf2normal_mod.f90 +ED/dbgbuild/bin/cdf_mod.f90 +ED/dbgbuild/bin/char_strip_var_mod.f90 +ED/dbgbuild/bin/charutils.f90 +ED/dbgbuild/bin/check_real_mod.f90 +ED/dbgbuild/bin/compute_budget_mod.f90 +ED/dbgbuild/bin/compute_c_and_n_storage_mod.f90 +ED/dbgbuild/bin/compute_co2_storage_mod.f90 +ED/dbgbuild/bin/compute_energy_storage_mod.f90 +ED/dbgbuild/bin/compute_netrad_mod.f90 +ED/dbgbuild/bin/compute_water_storage_mod.f90 +ED/dbgbuild/bin/copy_bdf2_prev_mod.f90 +ED/dbgbuild/bin/copy_fb_patch_mod.f90 +ED/dbgbuild/bin/copy_initp2prev_mod.f90 +ED/dbgbuild/bin/copy_met_2_rk4site_mod.f90 +ED/dbgbuild/bin/copy_nl_mod.f90 +ED/dbgbuild/bin/copy_patch_init_carbon_mod.f90 +ED/dbgbuild/bin/copy_patch_init_mod.f90 +ED/dbgbuild/bin/copy_path_from_grid_1_mod.f90 +ED/dbgbuild/bin/copy_prev2patch_mod.f90 +ED/dbgbuild/bin/copy_rk4_patch_mod.f90 +ED/dbgbuild/bin/count_pft_xml_config_mod.f90 +ED/dbgbuild/bin/cputime_mod.f90 +ED/dbgbuild/bin/create_ed10_ed20_fname_mod.f90 +ED/dbgbuild/bin/cumsum_mod.f90 +ED/dbgbuild/bin/cvmgm_mod.f90 +ED/dbgbuild/bin/cvmgn_mod.f90 +ED/dbgbuild/bin/cvmgp_mod.f90 +ED/dbgbuild/bin/cvmgz_mod.f90 +ED/dbgbuild/bin/date_2_seconds_mod.f90 +ED/dbgbuild/bin/date_abs_secs2_mod.f90 +ED/dbgbuild/bin/date_add_to_mod.f90 +ED/dbgbuild/bin/date_secs_ymdt_mod.f90 +ED/dbgbuild/bin/date_unmake_big_mod.f90 +ED/dbgbuild/bin/dateutils.f90 +ED/dbgbuild/bin/daylength_mod.f90 +ED/dbgbuild/bin/dcvmgm_mod.f90 +ED/dbgbuild/bin/dcvmgp_mod.f90 +ED/dbgbuild/bin/dcw_swap16_mod.f90 +ED/dbgbuild/bin/dcw_swap32_mod.f90 +ED/dbgbuild/bin/dcw_swap64_mod.f90 +ED/dbgbuild/bin/ddens_dt_effect_mod.f90 +ED/dbgbuild/bin/deblank_mod.f90 +ED/dbgbuild/bin/decomp_coms.f90 +ED/dbgbuild/bin/detab_mod.f90 +ED/dbgbuild/bin/detailed_coms.f90 +ED/dbgbuild/bin/diagon_mod.f90 +ED/dbgbuild/bin/dist_gc_mod.f90 +ED/dbgbuild/bin/disturbance.f90 +ED/dbgbuild/bin/disturb_coms.f90 +ED/dbgbuild/bin/dmax2_mod.f90 +ED/dbgbuild/bin/dmin2_mod.f90 +ED/dbgbuild/bin/dssum_mod.f90 +ED/dbgbuild/bin/dump_radinfo_mod.f90 +ED/dbgbuild/bin/ed1_fileinfo_mod.f90 +ED/dbgbuild/bin/ed_1st.f90 +ED/dbgbuild/bin/ed_1st_master_mod.f90 +ED/dbgbuild/bin/ed_1st_node_mod.f90 +ED/dbgbuild/bin/ed21_fileinfo_mod.f90 +ED/dbgbuild/bin/ed_datp_datq_mod.f90 +ED/dbgbuild/bin/ed_datp_datsoil_mod.f90 +ED/dbgbuild/bin/ed_driver.f90 +ED/dbgbuild/bin/ed_driver_mod.f90 +ED/dbgbuild/bin/ed_filelist_mod.f90 +ED/dbgbuild/bin/ed_grid.f90 +ED/dbgbuild/bin/ed_gridset_mod.f90 +ED/dbgbuild/bin/ed_init_atm_mod.f90 +ED/dbgbuild/bin/ed_init.f90 +ED/dbgbuild/bin/edio.f90 +ED/dbgbuild/bin/ed_ll_xy_mod.f90 +ED/dbgbuild/bin/ed_load_namelist.f90 +ED/dbgbuild/bin/ed_load_work_from_history_mod.f90 +ED/dbgbuild/bin/ed_masterput_met_header_mod.f90 +ED/dbgbuild/bin/ed_masterput_nl_mod.f90 +ED/dbgbuild/bin/ed_masterput_poly_dims_mod.f90 +ED/dbgbuild/bin/ed_masterput_processid_mod.f90 +ED/dbgbuild/bin/ed_masterput_worklist_info_mod.f90 +ED/dbgbuild/bin/ed_mem_alloc.f90 +ED/dbgbuild/bin/ed_mem_alloc_mod.f90 +ED/dbgbuild/bin/ed_mem_grid_dim_defs.f90 +ED/dbgbuild/bin/ed_met_driver.f90 +ED/dbgbuild/bin/ed_misc_coms.f90 +ED/dbgbuild/bin/ed_model.f90 +ED/dbgbuild/bin/ed_model_mod.f90 +ED/dbgbuild/bin/ed_mpass_init.f90 +ED/dbgbuild/bin/ed_nbg_init.f90 +ED/dbgbuild/bin/ed_newgrid_mod.f90 +ED/dbgbuild/bin/ed_node_coms.f90 +ED/dbgbuild/bin/ed_node_decomp_mod.f90 +ED/dbgbuild/bin/ed_nodeget_met_header_mod.f90 +ED/dbgbuild/bin/ed_nodeget_nl_mod.f90 +ED/dbgbuild/bin/ed_nodeget_poly_dims_mod.f90 +ED/dbgbuild/bin/ed_nodeget_processid_mod.f90 +ED/dbgbuild/bin/ed_nodeget_worklist_info_mod.f90 +ED/dbgbuild/bin/ed_opspec_grid_mod.f90 +ED/dbgbuild/bin/ed_opspec_misc_mod.f90 +ED/dbgbuild/bin/ed_opspec_par_mod.f90 +ED/dbgbuild/bin/ed_opspec_times_mod.f90 +ED/dbgbuild/bin/ed_output_mod.f90 +ED/dbgbuild/bin/ed_para_coms.f90 +ED/dbgbuild/bin/ed_params.f90 +ED/dbgbuild/bin/ed_parvec_work_mod.f90 +ED/dbgbuild/bin/ed_polarst_mod.f90 +ED/dbgbuild/bin/ed_print.f90 +ED/dbgbuild/bin/ed_read_ed10_20_history.f90 +ED/dbgbuild/bin/ed_state_vars.f90 +ED/dbgbuild/bin/ed_therm_lib.f90 +ED/dbgbuild/bin/ed_type_init.f90 +ED/dbgbuild/bin/ed_var_tables.f90 +ED/dbgbuild/bin/ed_work_vars.f90 +ED/dbgbuild/bin/ed_xml_config.f90 +ED/dbgbuild/bin/ed_xy_ll_mod.f90 +ED/dbgbuild/bin/ed_zen_mod.f90 +ED/dbgbuild/bin/eifun8_mod.f90 +ED/dbgbuild/bin/elgs_mod.f90 +ED/dbgbuild/bin/ename_coms.f90 +ED/dbgbuild/bin/endian_mod.f90 +ED/dbgbuild/bin/errorfun_mod.f90 +ED/dbgbuild/bin/euler_driver.f90 +ED/dbgbuild/bin/euler_integ_mod.f90 +ED/dbgbuild/bin/euler_timestep_mod.f90 +ED/dbgbuild/bin/event_fertilize_mod.f90 +ED/dbgbuild/bin/event_fire_mod.f90 +ED/dbgbuild/bin/event_harvest_mod.f90 +ED/dbgbuild/bin/event_irrigate_mod.f90 +ED/dbgbuild/bin/event_planting_mod.f90 +ED/dbgbuild/bin/events.f90 +ED/dbgbuild/bin/event_till_mod.f90 +ED/dbgbuild/bin/expected_mod.f90 +ED/dbgbuild/bin/expmsq_mod.f90 +ED/dbgbuild/bin/exterminate_patches_except_mod.f90 +ED/dbgbuild/bin/fail_whale_mod.f90 +ED/dbgbuild/bin/farq_leuning.f90 +ED/dbgbuild/bin/fatal_error.f90 +ED/dbgbuild/bin/fatal_error_mod.f90 +ED/dbgbuild/bin/fb_dy_step_trunc_mod.f90 +ED/dbgbuild/bin/fb_sanity_check_mod.f90 +ED/dbgbuild/bin/fill_history_grid_mod.f90 +ED/dbgbuild/bin/fill_history_patch_mod.f90 +ED/dbgbuild/bin/fill_history_polygon_mod.f90 +ED/dbgbuild/bin/fill_history_site_mod.f90 +ED/dbgbuild/bin/fillvar_l_mod.f90 +ED/dbgbuild/bin/find_closing_comment_mod.f90 +ED/dbgbuild/bin/find_frqsum_mod.f90 +ED/dbgbuild/bin/findln_mod.f90 +ED/dbgbuild/bin/find_rank_mod.f90 +ED/dbgbuild/bin/fire.f90 +ED/dbgbuild/bin/fire_frequency_mod.f90 +ED/dbgbuild/bin/first_phenology_mod.f90 +ED/dbgbuild/bin/flag_stable_cohorts_mod.f90 +ED/dbgbuild/bin/forestry.f90 +ED/dbgbuild/bin/fuse_fiss_utils.f90 +ED/dbgbuild/bin/fusion_fission_coms.f90 +ED/dbgbuild/bin/getconfigint_mod.f90 +ED/dbgbuild/bin/getconfigreal_mod.f90 +ED/dbgbuild/bin/getconfigstring_mod.f90 +ED/dbgbuild/bin/get_errmax_mod.f90 +ED/dbgbuild/bin/get_file_indices_mod.f90 +ED/dbgbuild/bin/get_grid_mod.f90 +ED/dbgbuild/bin/geth5dims_mod.f90 +ED/dbgbuild/bin/getll_mod.f90 +ED/dbgbuild/bin/get_work_mod.f90 +ED/dbgbuild/bin/get_yscal_mod.f90 +ED/dbgbuild/bin/great_circle.f90 +ED/dbgbuild/bin/grid_coms.f90 +ED/dbgbuild/bin/growth_balive.f90 +ED/dbgbuild/bin/h5_output_mod.f90 +ED/dbgbuild/bin/harv_immat_patches_mod.f90 +ED/dbgbuild/bin/harv_mat_patches_mod.f90 +ED/dbgbuild/bin/hdf_getslab_d_mod.f90 +ED/dbgbuild/bin/hdf_getslab_i_mod.f90 +ED/dbgbuild/bin/hdf_getslab_r_mod.f90 +ED/dbgbuild/bin/heav_mod.f90 +ED/dbgbuild/bin/het_resp_weight_mod.f90 +ED/dbgbuild/bin/heun_driver.f90 +ED/dbgbuild/bin/heun_integ_mod.f90 +ED/dbgbuild/bin/heun_stepper_mod.f90 +ED/dbgbuild/bin/heun_timestep_mod.f90 +ED/dbgbuild/bin/how_to_read_a_file_mod.f90 +ED/dbgbuild/bin/hybrid_driver.f90 +ED/dbgbuild/bin/hybrid_integ_mod.f90 +ED/dbgbuild/bin/hybrid_timestep_mod.f90 +ED/dbgbuild/bin/hydrology_coms.f90 +ED/dbgbuild/bin/hydrology_constants.f90 +ED/dbgbuild/bin/ibias_mod.f90 +ED/dbgbuild/bin/ibindec_mod.f90 +ED/dbgbuild/bin/ifirstchar_mod.f90 +ED/dbgbuild/bin/inc_fwd_patch_mod.f90 +ED/dbgbuild/bin/inc_rk4_patch_mod.f90 +ED/dbgbuild/bin/init_can_air_params_mod.f90 +ED/dbgbuild/bin/init_can_lyr_params_mod.f90 +ED/dbgbuild/bin/init_can_rad_params_mod.f90 +ED/dbgbuild/bin/init_cohorts_by_layers_mod.f90 +ED/dbgbuild/bin/init_decomp_params_mod.f90 +ED/dbgbuild/bin/init_disturb_params_mod.f90 +ED/dbgbuild/bin/init_ed_cohort_vars_mod.f90 +ED/dbgbuild/bin/init_ed_misc_coms_mod.f90 +ED/dbgbuild/bin/init_ed_patch_vars_mod.f90 +ED/dbgbuild/bin/init_ed_poly_vars_mod.f90 +ED/dbgbuild/bin/init_ed_site_vars_mod.f90 +ED/dbgbuild/bin/init_ff_coms_mod.f90 +ED/dbgbuild/bin/init_full_history_restart_mod.f90 +ED/dbgbuild/bin/init_hydro_coms_mod.f90 +ED/dbgbuild/bin/inithydrology_mod.f90 +ED/dbgbuild/bin/init_hydro_sites.f90 +ED/dbgbuild/bin/inithydrosubsurface_mod.f90 +ED/dbgbuild/bin/initialize_rk4patches_mod.f90 +ED/dbgbuild/bin/init_lapse_params_mod.f90 +ED/dbgbuild/bin/init_met_drivers_mod.f90 +ED/dbgbuild/bin/init_met_params_mod.f90 +ED/dbgbuild/bin/init_nbg_cohorts_mod.f90 +ED/dbgbuild/bin/init_pft_alloc_params_mod.f90 +ED/dbgbuild/bin/init_pft_derived_params_mod.f90 +ED/dbgbuild/bin/init_pft_leaf_params_mod.f90 +ED/dbgbuild/bin/init_pft_mort_params_mod.f90 +ED/dbgbuild/bin/init_pft_nitro_params_mod.f90 +ED/dbgbuild/bin/init_pft_photo_params_mod.f90 +ED/dbgbuild/bin/init_pft_repro_params_mod.f90 +ED/dbgbuild/bin/init_pft_resp_params_mod.f90 +ED/dbgbuild/bin/init_phen_coms_mod.f90 +ED/dbgbuild/bin/init_physiology_params_mod.f90 +ED/dbgbuild/bin/init_rk4_params_mod.f90 +ED/dbgbuild/bin/init_soil_coms_mod.f90 +ED/dbgbuild/bin/integrate_ed_daily_output_flux_mod.f90 +ED/dbgbuild/bin/integrate_ed_daily_output_state_mod.f90 +ED/dbgbuild/bin/integrate_ed_monthly_output_vars_mod.f90 +ED/dbgbuild/bin/integrate_patch_euler_mod.f90 +ED/dbgbuild/bin/integrate_patch_heun_mod.f90 +ED/dbgbuild/bin/int_met_avg_mod.f90 +ED/dbgbuild/bin/inventory_mat_forests_mod.f90 +ED/dbgbuild/bin/invmondays.f90 +ED/dbgbuild/bin/iprim_mod.f90 +ED/dbgbuild/bin/iran_recsize_mod.f90 +ED/dbgbuild/bin/is_finite8_mod.f90 +ED/dbgbuild/bin/is_finite_mod.f90 +ED/dbgbuild/bin/isleap_mod.f90 +ED/dbgbuild/bin/ismax_mod.f90 +ED/dbgbuild/bin/ismin_mod.f90 +ED/dbgbuild/bin/is_resolvable_mod.f90 +ED/dbgbuild/bin/ivalugp_mod.f90 +ED/dbgbuild/bin/izero2_mod.f90 +ED/dbgbuild/bin/izero3_mod.f90 +ED/dbgbuild/bin/izero4_mod.f90 +ED/dbgbuild/bin/izero5_mod.f90 +ED/dbgbuild/bin/izero_mod.f90 +ED/dbgbuild/bin/izerov_mod.f90 +ED/dbgbuild/bin/julday1000_mod.f90 +ED/dbgbuild/bin/julday_mod.f90 +ED/dbgbuild/bin/landuse_init.f90 +ED/dbgbuild/bin/landuse_init_mod.f90 +ED/dbgbuild/bin/lapse.f90 +ED/dbgbuild/bin/large_error_mod.f90 +ED/dbgbuild/bin/lastchar_mod.f90 +ED/dbgbuild/bin/lastmonthdate_mod.f90 +ED/dbgbuild/bin/lastslash_mod.f90 +ED/dbgbuild/bin/leaf_database.f90 +ED/dbgbuild/bin/leaf_database_mod.f90 +ED/dbgbuild/bin/leaf_derivs_mod.f90 +ED/dbgbuild/bin/leaftw_derivs_mod.f90 +ED/dbgbuild/bin/libxml2f90__closeall_mod.f90 +ED/dbgbuild/bin/libxml2f90__closefile_mod.f90 +ED/dbgbuild/bin/libxml2f90_error_getline_mod.f90 +ED/dbgbuild/bin/libxml2f90__existid_mod.f90 +ED/dbgbuild/bin/libxml2f90_existid_mod.f90 +ED/dbgbuild/bin/libxml2f90__existpid_mod.f90 +ED/dbgbuild/bin/libxml2f90.f90_pp.f90 +ED/dbgbuild/bin/libxml2f90__findinchara_mod.f90 +ED/dbgbuild/bin/libxml2f90__flush_mod.f90 +ED/dbgbuild/bin/libxml2f90__get_fileunit_mod.f90 +ED/dbgbuild/bin/libxml2f90_getline_mod.f90 +ED/dbgbuild/bin/libxml2f90_getsafec8_mod.f90 +ED/dbgbuild/bin/libxml2f90_getsafei4_mod.f90 +ED/dbgbuild/bin/libxml2f90_getsafel4_mod.f90 +ED/dbgbuild/bin/libxml2f90_getsafer8_mod.f90 +ED/dbgbuild/bin/libxml2f90__getunit_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_addid_mod.f90 +ED/dbgbuild/bin/libxml2f90_ll_addid_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_add_list_mod.f90 +ED/dbgbuild/bin/libxml2f90_ll_add_list_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_addpid_mod.f90 +ED/dbgbuild/bin/libxml2f90_ll_addpid_mod.f90 +ED/dbgbuild/bin/libxml2f90_ll_addpureid_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_closetag_mod.f90 +ED/dbgbuild/bin/libxml2f90_ll_closetag_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_down_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_edit_id_mod.f90 +ED/dbgbuild/bin/libxml2f90_ll_edit_id_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_edit_pid_mod.f90 +ED/dbgbuild/bin/libxml2f90_ll_edit_pid_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_exist_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getc8__mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getc8_mod.f90 +ED/dbgbuild/bin/libxml2f90_ll_getc8_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getch_mod.f90 +ED/dbgbuild/bin/libxml2f90_ll_getch_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getch_scal_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_geti4__mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_geti4_mod.f90 +ED/dbgbuild/bin/libxml2f90_ll_geti4_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getl4__mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getl4_mod.f90 +ED/dbgbuild/bin/libxml2f90_ll_getl4_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getpc8__mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getpc8_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getpch_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getpi4__mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getpi4_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getpl4__mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getpl4_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getpr8__mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getpr8_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getpsize_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getpstring__mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getpstring_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getr8__mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getr8_mod.f90 +ED/dbgbuild/bin/libxml2f90_ll_getr8_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getsize_mod.f90 +ED/dbgbuild/bin/libxml2f90_ll_getsize_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getstring__mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_getstring_mod.f90 +ED/dbgbuild/bin/libxml2f90_ll_getstring_mod.f90 +ED/dbgbuild/bin/libxml2f90_ll_initlist_mod.f90 +ED/dbgbuild/bin/libxml2f90_ll_inittag_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_opentag_mod.f90 +ED/dbgbuild/bin/libxml2f90_ll_opentag_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_report_mod.f90 +ED/dbgbuild/bin/libxml2f90_ll_report_rec_mod.f90 +ED/dbgbuild/bin/libxml2f90_ll_report_rec_wrap_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_selectlist_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_selecttag_mod.f90 +ED/dbgbuild/bin/libxml2f90__ll_up_mod.f90 +ED/dbgbuild/bin/libxml2f90__openfile_mod.f90 +ED/dbgbuild/bin/libxml2f90_parse_file_mod.f90 +ED/dbgbuild/bin/libxml2f90_parse_find_char_mod.f90 +ED/dbgbuild/bin/libxml2f90__readin_file_mod.f90 +ED/dbgbuild/bin/libxml2f90_readin_file_mod.f90 +ED/dbgbuild/bin/libxml2f90__readin_nfil_mod.f90 +ED/dbgbuild/bin/libxml2f90__set_casesensitive_mod.f90 +ED/dbgbuild/bin/libxml2f90__set_default_ll_id_mod.f90 +ED/dbgbuild/bin/libxml2f90__setformat_mod.f90 +ED/dbgbuild/bin/libxml2f90__set_paw_mod.f90 +ED/dbgbuild/bin/libxml2f90__set_rmcomma_mod.f90 +ED/dbgbuild/bin/libxml2f90__set_rmquotes_mod.f90 +ED/dbgbuild/bin/libxml2f90__settransform_exm_mod.f90 +ED/dbgbuild/bin/libxml2f90__setwrite_exm_mod.f90 +ED/dbgbuild/bin/libxml2f90_tostringa_mod.f90 +ED/dbgbuild/bin/libxml2f90_tostring_mod.f90 +ED/dbgbuild/bin/libxml2f90_transform_paw_mod.f90 +ED/dbgbuild/bin/lisys_solver8_mod.f90 +ED/dbgbuild/bin/lisys_solver_mod.f90 +ED/dbgbuild/bin/load_ecosystem_state_mod.f90 +ED/dbgbuild/bin/load_ed_ecosystem_params_mod.f90 +ED/dbgbuild/bin/lsm_hyd.f90 +ED/dbgbuild/bin/lubksb_dble_mod.f90 +ED/dbgbuild/bin/ludcmp_dble_mod.f90 +ED/dbgbuild/bin/lw_multiple_scatter_mod.f90 +ED/dbgbuild/bin/lw_twostream_mod.f90 +ED/dbgbuild/bin/makefnam_mod.f90 +ED/dbgbuild/bin/match_poly_grid_mod.f90 +ED/dbgbuild/bin/mat_forest_harv_rates_mod.f90 +ED/dbgbuild/bin/mean_daysecz_mod.f90 +ED/dbgbuild/bin/mem_polygons.f90 +ED/dbgbuild/bin/met_driver_coms.f90 +ED/dbgbuild/bin/met_sanity_check_mod.f90 +ED/dbgbuild/bin/migs_mod.f90 +ED/dbgbuild/bin/mk_2_buff_mod.f90 +ED/dbgbuild/bin/mk_2p_buff_mod.f90 +ED/dbgbuild/bin/mk_3_buff_mod.f90 +ED/dbgbuild/bin/mk_4_buff_mod.f90 +ED/dbgbuild/bin/mortality.f90 +ED/dbgbuild/bin/mprove_mod.f90 +ED/dbgbuild/bin/multiple_scatter.f90 +ED/dbgbuild/bin/near_bare_ground_big_leaf_init_mod.f90 +ED/dbgbuild/bin/near_bare_ground_init_mod.f90 +ED/dbgbuild/bin/new_patch_sfc_props_mod.f90 +ED/dbgbuild/bin/normalize_averaged_vars_mod.f90 +ED/dbgbuild/bin/normalize_ed_dailynpp_vars_mod.f90 +ED/dbgbuild/bin/normalize_ed_daily_output_vars_mod.f90 +ED/dbgbuild/bin/normalize_ed_daily_vars_mod.f90 +ED/dbgbuild/bin/normalize_ed_monthly_output_vars_mod.f90 +ED/dbgbuild/bin/norm_harv_patch_mod.f90 +ED/dbgbuild/bin/num_days_mod.f90 +ED/dbgbuild/bin/numutils.f90 +ED/dbgbuild/bin/odeint_mod.f90 +ED/dbgbuild/bin/opspec_fatal_mod.f90 +ED/dbgbuild/bin/optimiz_coms.f90 +ED/dbgbuild/bin/overwrite_with_xml_config_mod.f90 +ED/dbgbuild/bin/parsefnam_mod.f90 +ED/dbgbuild/bin/parse_mod.f90 +ED/dbgbuild/bin/pft_coms.f90 +ED/dbgbuild/bin/pheninit_balive_bstorage_mod.f90 +ED/dbgbuild/bin/phenology_aux.f90 +ED/dbgbuild/bin/phenology_coms.f90 +ED/dbgbuild/bin/phenology_driver_eq_0_mod.f90 +ED/dbgbuild/bin/phenology_driver_mod.f90 +ED/dbgbuild/bin/phenology_driv.f90 +ED/dbgbuild/bin/phenology_startup.f90 +ED/dbgbuild/bin/phenology_thresholds_mod.f90 +ED/dbgbuild/bin/photosyn_driv.f90 +ED/dbgbuild/bin/physiology_coms.f90 +ED/dbgbuild/bin/plant_structural_allocation_mod.f90 +ED/dbgbuild/bin/prescribed_event_mod.f90 +ED/dbgbuild/bin/prescribed_leaf_state_mod.f90 +ED/dbgbuild/bin/print_c_and_n_budgets_mod.f90 +ED/dbgbuild/bin/print_csiteipa_mod.f90 +ED/dbgbuild/bin/print_errmax_mod.f90 +ED/dbgbuild/bin/print_fields_mod.f90 +ED/dbgbuild/bin/print_photo_details_mod.f90 +ED/dbgbuild/bin/print_rk4patch_mod.f90 +ED/dbgbuild/bin/print_rk4_state_mod.f90 +ED/dbgbuild/bin/print_soil_info_mod.f90 +ED/dbgbuild/bin/putconfigint_mod.f90 +ED/dbgbuild/bin/putconfigreal8_mod.f90 +ED/dbgbuild/bin/putconfigreal_mod.f90 +ED/dbgbuild/bin/putconfigstring_mod.f90 +ED/dbgbuild/bin/radiate_driver.f90 +ED/dbgbuild/bin/radiate_driver_mod.f90 +ED/dbgbuild/bin/radiate_utils.f90 +ED/dbgbuild/bin/rams_f_open_mod.f90 +ED/dbgbuild/bin/rank_down_mod.f90 +ED/dbgbuild/bin/rank_up_mod.f90 +ED/dbgbuild/bin/read_ed10_ed20_history_file_mod.f90 +ED/dbgbuild/bin/read_ed21_history_file_mod.f90 +ED/dbgbuild/bin/read_ed21_history_unstruct_mod.f90 +ED/dbgbuild/bin/read_ed_xml_config_mod.f90 +ED/dbgbuild/bin/read_events_xml_mod.f90 +ED/dbgbuild/bin/read_met_driver_head_mod.f90 +ED/dbgbuild/bin/read_met_drivers_init_mod.f90 +ED/dbgbuild/bin/read_met_drivers_mod.f90 +ED/dbgbuild/bin/read_nl_mod.f90 +ED/dbgbuild/bin/read_ol_file_mod.f90 +ED/dbgbuild/bin/read_plantation_fractions_mod.f90 +ED/dbgbuild/bin/read_site_file_mod.f90 +ED/dbgbuild/bin/read_soil_depth_mod.f90 +ED/dbgbuild/bin/read_soil_moist_temp_mod.f90 +ED/dbgbuild/bin/rearrange_mod.f90 +ED/dbgbuild/bin/reproduction_eq_0_mod.f90 +ED/dbgbuild/bin/reproduction.f90 +ED/dbgbuild/bin/reproduction_mod.f90 +ED/dbgbuild/bin/reset_averaged_vars_mod.f90 +ED/dbgbuild/bin/resp_f_decomp_mod.f90 +ED/dbgbuild/bin/resp_rh_mod.f90 +ED/dbgbuild/bin/rk4_coms.f90 +ED/dbgbuild/bin/rk4_integ_utils.f90 +ED/dbgbuild/bin/rk4_misc.f90 +ED/dbgbuild/bin/root_resp_norm_mod.f90 +ED/dbgbuild/bin/scale_ed_radiation_mod.f90 +ED/dbgbuild/bin/seed_dispersal_mod.f90 +ED/dbgbuild/bin/selective_gaussian_2body_mod.f90 +ED/dbgbuild/bin/setlapseparms_mod.f90 +ED/dbgbuild/bin/set_polygon_coordinates_mod.f90 +ED/dbgbuild/bin/set_site_defprops_mod.f90 +ED/dbgbuild/bin/sfcdata_ed_mod.f90 +ED/dbgbuild/bin/sfcrad_ed_mod.f90 +ED/dbgbuild/bin/short2diff_sib_mod.f90 +ED/dbgbuild/bin/short_bdown_weissnorman_mod.f90 +ED/dbgbuild/bin/sngloff_mod.f90 +ED/dbgbuild/bin/soil_depth_fill_mod.f90 +ED/dbgbuild/bin/soil_respiration.f90 +ED/dbgbuild/bin/soil_respiration_mod.f90 +ED/dbgbuild/bin/solar_radiation_breakdown_mod.f90 +ED/dbgbuild/bin/sort3_mod.f90 +ED/dbgbuild/bin/sort_down_mod.f90 +ED/dbgbuild/bin/sort_up_mod.f90 +ED/dbgbuild/bin/spatial_averages_mod.f90 +ED/dbgbuild/bin/ssum_mod.f90 +ED/dbgbuild/bin/stable_cohorts.f90 +ED/dbgbuild/bin/structural_growth_eq_0_mod.f90 +ED/dbgbuild/bin/structural_growth.f90 +ED/dbgbuild/bin/structural_growth_mod.f90 +ED/dbgbuild/bin/sum_plant_cfluxes_mod.f90 +ED/dbgbuild/bin/sw_multiple_scatter_mod.f90 +ED/dbgbuild/bin/sw_twostream_clump_mod.f90 +ED/dbgbuild/bin/test_mod.f90 +ED/dbgbuild/bin/therm_lib8.f90 +ED/dbgbuild/bin/therm_lib.f90 +ED/dbgbuild/bin/timing_mod.f90 +ED/dbgbuild/bin/tokenize1_mod.f90 +ED/dbgbuild/bin/tolower_mod.f90 +ED/dbgbuild/bin/transfer_ol_month_mod.f90 +ED/dbgbuild/bin/trid2_mod.f90 +ED/dbgbuild/bin/trid_mod.f90 +ED/dbgbuild/bin/twostream_rad.f90 +ED/dbgbuild/bin/ugetarg_mod.f90 +ED/dbgbuild/bin/unarrange_mod.f90 +ED/dbgbuild/bin/update_budget_mod.f90 +ED/dbgbuild/bin/update_c_and_n_pools_mod.f90 +ED/dbgbuild/bin/update_derived_cohort_props_mod.f90 +ED/dbgbuild/bin/update_derived_props.f90 +ED/dbgbuild/bin/update_derived_props_mod.f90 +ED/dbgbuild/bin/update_diagnostic_vars_mod.f90 +ED/dbgbuild/bin/update_ed_yearly_vars_mod.f90 +ED/dbgbuild/bin/updatehydroparms_mod.f90 +ED/dbgbuild/bin/update_met_drivers_mod.f90 +ED/dbgbuild/bin/update_model_time_dm_mod.f90 +ED/dbgbuild/bin/update_mod.f90 +ED/dbgbuild/bin/update_patch_derived_props_mod.f90 +ED/dbgbuild/bin/update_patch_thermo_props_mod.f90 +ED/dbgbuild/bin/update_phenology_eq_0_mod.f90 +ED/dbgbuild/bin/update_phenology_mod.f90 +ED/dbgbuild/bin/update_polygon_derived_props_mod.f90 +ED/dbgbuild/bin/update_rad_avg_mod.f90 +ED/dbgbuild/bin/update_site_derived_props_mod.f90 +ED/dbgbuild/bin/update_thermal_sums_mod.f90 +ED/dbgbuild/bin/update_turnover_mod.f90 +ED/dbgbuild/bin/update_vital_rates_mod.f90 +ED/dbgbuild/bin/updatewatertableadd_mod.f90 +ED/dbgbuild/bin/updatewatertablebaseflow_mod.f90 +ED/dbgbuild/bin/updatewatertablesubtract_mod.f90 +ED/dbgbuild/bin/update_workload_mod.f90 +ED/dbgbuild/bin/utils_f.f90 +ED/dbgbuild/bin/valugp_mod.f90 +ED/dbgbuild/bin/vegetation_dynamics_eq_0_mod.f90 +ED/dbgbuild/bin/vegetation_dynamics.f90 +ED/dbgbuild/bin/vegetation_dynamics_mod.f90 +ED/dbgbuild/bin/walltime_mod.f90 +ED/dbgbuild/bin/warning_mod.f90 +ED/dbgbuild/bin/write_ed_xml_config_mod.f90 +ED/dbgbuild/bin/writehydro_mod.f90 +ED/dbgbuild/bin/xcol2array_mod.f90 +ED/dbgbuild/bin/ycol2array_mod.f90 +ED/dbgbuild/bin/yesterday_mod.f90 +ED/dbgbuild/bin/zcol2array_mod.f90 +ED/dbgbuild/bin/zero_ed_daily_output_vars_mod.f90 +ED/dbgbuild/bin/zero_ed_daily_vars_mod.f90 +ED/dbgbuild/bin/zero_ed_monthly_output_vars_mod.f90 +ED/dbgbuild/bin/zero_ed_yearly_vars_mod.f90 +ED/build/bin/detailed_coms.mod +ED/amd_build +tmp_stuff +BRAMS/i11dbg/bin/adap_init.f90 +BRAMS/i11dbg/bin/allometry.f90 +BRAMS/i11dbg/bin/altera_dia.f90 +BRAMS/i11dbg/bin/an_header.f90 +BRAMS/i11dbg/bin/aobj.f90 +BRAMS/i11dbg/bin/asgen.f90 +BRAMS/i11dbg/bin/asti2.f90 +BRAMS/i11dbg/bin/asti.f90 +BRAMS/i11dbg/bin/astp.f90 +BRAMS/i11dbg/bin/avarf.f90 +BRAMS/i11dbg/bin/average_utils.f90 +BRAMS/i11dbg/bin/bdf2_solver.f90 +BRAMS/i11dbg/bin/budget_utils.f90 +BRAMS/i11dbg/bin/c34constants.f90 +BRAMS/i11dbg/bin/canopy_air_coms.f90 +BRAMS/i11dbg/bin/canopy_radiation_coms.f90 +BRAMS/i11dbg/bin/canopy_struct_dynamics.f90 +BRAMS/i11dbg/bin/catt_start.f90 +BRAMS/i11dbg/bin/charutils.f90 +BRAMS/i11dbg/bin/cond_read.f90 +BRAMS/i11dbg/bin/cond_update.f90 +BRAMS/i11dbg/bin/conv_coms.f90 +BRAMS/i11dbg/bin/coriolis.f90 +BRAMS/i11dbg/bin/cup_dn.f90 +BRAMS/i11dbg/bin/cup_env.f90 +BRAMS/i11dbg/bin/cup_grell2.f90 +BRAMS/i11dbg/bin/cup_grell2_shcu.f90 +BRAMS/i11dbg/bin/cup_up.f90 +BRAMS/i11dbg/bin/cu_read.f90 +BRAMS/i11dbg/bin/cyclic_mod.f90 +BRAMS/i11dbg/bin/dateutils.f90 +BRAMS/i11dbg/bin/dealloc.f90 +BRAMS/i11dbg/bin/decomp_coms.f90 +BRAMS/i11dbg/bin/detailed_coms.f90 +BRAMS/i11dbg/bin/diffsclr.f90 +BRAMS/i11dbg/bin/diffuse.f90 +BRAMS/i11dbg/bin/disturbance.f90 +BRAMS/i11dbg/bin/disturb_coms.f90 +BRAMS/i11dbg/bin/domain_decomp.f90 +BRAMS/i11dbg/bin/dry_dep.f90 +BRAMS/i11dbg/bin/edcp_driver.f90 +BRAMS/i11dbg/bin/edcp_init.f90 +BRAMS/i11dbg/bin/edcp_lake_driver.f90 +BRAMS/i11dbg/bin/edcp_lake_misc.f90 +BRAMS/i11dbg/bin/edcp_lake_stepper.f90 +BRAMS/i11dbg/bin/edcp_load_namelist.f90 +BRAMS/i11dbg/bin/edcp_met.f90 +BRAMS/i11dbg/bin/edcp_met_init.f90 +BRAMS/i11dbg/bin/edcp_model.f90 +BRAMS/i11dbg/bin/edcp_mpiutils.f90 +BRAMS/i11dbg/bin/edcp_para_init.f90 +BRAMS/i11dbg/bin/ed_grid.f90 +BRAMS/i11dbg/bin/ed_init.f90 +BRAMS/i11dbg/bin/edio.f90 +BRAMS/i11dbg/bin/ed_mem_grid_dim_defs.f90 +BRAMS/i11dbg/bin/ed_misc_coms.f90 +BRAMS/i11dbg/bin/ed_nbg_init.f90 +BRAMS/i11dbg/bin/ed_node_coms.f90 +BRAMS/i11dbg/bin/ed_para_coms.f90 +BRAMS/i11dbg/bin/ed_params.f90 +BRAMS/i11dbg/bin/ed_print.f90 +BRAMS/i11dbg/bin/ed_read_ed10_20_history.f90 +BRAMS/i11dbg/bin/ed_state_vars.f90 +BRAMS/i11dbg/bin/ed_therm_lib.f90 +BRAMS/i11dbg/bin/ed_type_init.f90 +BRAMS/i11dbg/bin/ed_var_tables.f90 +BRAMS/i11dbg/bin/ed_work_vars.f90 +BRAMS/i11dbg/bin/ed_xml_config.f90 +BRAMS/i11dbg/bin/emission_source_map.f90 +BRAMS/i11dbg/bin/ename_coms.f90 +BRAMS/i11dbg/bin/error_mess.f90 +BRAMS/i11dbg/bin/euler_driver.f90 +BRAMS/i11dbg/bin/events.f90 +BRAMS/i11dbg/bin/extra.f90 +BRAMS/i11dbg/bin/farq_leuning.f90 +BRAMS/i11dbg/bin/fatal_error.f90 +BRAMS/i11dbg/bin/file_inv.f90 +BRAMS/i11dbg/bin/fire.f90 +BRAMS/i11dbg/bin/first_rams.f90 +BRAMS/i11dbg/bin/forestry.f90 +BRAMS/i11dbg/bin/fuse_fiss_utils.f90 +BRAMS/i11dbg/bin/fusion_fission_coms.f90 +BRAMS/i11dbg/bin/gaspart.f90 +BRAMS/i11dbg/bin/geodat.f90 +BRAMS/i11dbg/bin/getvar.f90 +BRAMS/i11dbg/bin/great_circle.f90 +BRAMS/i11dbg/bin/grell_coms.f90 +BRAMS/i11dbg/bin/grell_cupar_aux.f90 +BRAMS/i11dbg/bin/grell_cupar_downdraft.f90 +BRAMS/i11dbg/bin/grell_cupar_driver.f90 +BRAMS/i11dbg/bin/grell_cupar_dynamic.f90 +BRAMS/i11dbg/bin/grell_cupar_ensemble.f90 +BRAMS/i11dbg/bin/grell_cupar_environment.f90 +BRAMS/i11dbg/bin/grell_cupar_feedback.f90 +BRAMS/i11dbg/bin/grell_cupar_static.f90 +BRAMS/i11dbg/bin/grell_cupar_updraft.f90 +BRAMS/i11dbg/bin/grell_extras_catt.f90 +BRAMS/i11dbg/bin/grid_coms.f90 +BRAMS/i11dbg/bin/grid_dims.f90 +BRAMS/i11dbg/bin/gridset.f90 +BRAMS/i11dbg/bin/grid_struct.f90 +BRAMS/i11dbg/bin/growth_balive.f90 +BRAMS/i11dbg/bin/harr_coms.f90 +BRAMS/i11dbg/bin/harr_raddriv.f90 +BRAMS/i11dbg/bin/harr_radinit.f90 +BRAMS/i11dbg/bin/hemi2.f90 +BRAMS/i11dbg/bin/heun_driver.f90 +BRAMS/i11dbg/bin/htint-opt.f90 +BRAMS/i11dbg/bin/hybrid_driver.f90 +BRAMS/i11dbg/bin/hydrology_coms.f90 +BRAMS/i11dbg/bin/hydrology_constants.f90 +BRAMS/i11dbg/bin/inithis.f90 +BRAMS/i11dbg/bin/init_hydro_sites.f90 +BRAMS/i11dbg/bin/interp_lib.f90 +BRAMS/i11dbg/bin/invmondays.f90 +BRAMS/i11dbg/bin/io_params.f90 +BRAMS/i11dbg/bin/isan_coms.f90 +BRAMS/i11dbg/bin/isan_io.f90 +BRAMS/i11dbg/bin/ke_coms.f90 +BRAMS/i11dbg/bin/kuo_cupar_driver.f90 +BRAMS/i11dbg/bin/lake_coms.f90 +BRAMS/i11dbg/bin/landuse_init.f90 +BRAMS/i11dbg/bin/lapse.f90 +BRAMS/i11dbg/bin/leaf3_bc.f90 +BRAMS/i11dbg/bin/leaf3_can.f90 +BRAMS/i11dbg/bin/leaf3.f90 +BRAMS/i11dbg/bin/leaf3_hyd.f90 +BRAMS/i11dbg/bin/leaf3_init.f90 +BRAMS/i11dbg/bin/leaf3_ocean.f90 +BRAMS/i11dbg/bin/leaf3_teb.f90 +BRAMS/i11dbg/bin/leaf3_tw.f90 +BRAMS/i11dbg/bin/leaf3_utils.f90 +BRAMS/i11dbg/bin/leaf_coms.f90 +BRAMS/i11dbg/bin/leaf_database.f90 +BRAMS/i11dbg/bin/libxml2f90.f90_pp.f90 +BRAMS/i11dbg/bin/local_proc.f90 +BRAMS/i11dbg/bin/lsm_hyd.f90 +BRAMS/i11dbg/bin/map_proj.f90 +BRAMS/i11dbg/bin/mem_aerad.f90 +BRAMS/i11dbg/bin/mem_all.f90 +BRAMS/i11dbg/bin/mem_basic.f90 +BRAMS/i11dbg/bin/mem_carma.f90 +BRAMS/i11dbg/bin/mem_cuparm.f90 +BRAMS/i11dbg/bin/mem_edcp.f90 +BRAMS/i11dbg/bin/mem_emiss.f90 +BRAMS/i11dbg/bin/mem_ensemble.f90 +BRAMS/i11dbg/bin/mem_gaspart.f90 +BRAMS/i11dbg/bin/mem_globaer.f90 +BRAMS/i11dbg/bin/mem_globrad.f90 +BRAMS/i11dbg/bin/mem_grell_param2.f90 +BRAMS/i11dbg/bin/mem_grid_dim_defs.f90 +BRAMS/i11dbg/bin/mem_grid.f90 +BRAMS/i11dbg/bin/mem_harr.f90 +BRAMS/i11dbg/bin/mem_leaf.f90 +BRAMS/i11dbg/bin/mem_mass.f90 +BRAMS/i11dbg/bin/mem_mclat.f90 +BRAMS/i11dbg/bin/mem_micro.f90 +BRAMS/i11dbg/bin/mem_mksfc.f90 +BRAMS/i11dbg/bin/mem_mnt_advec.f90 +BRAMS/i11dbg/bin/mem_nestb.f90 +BRAMS/i11dbg/bin/mem_oda.f90 +BRAMS/i11dbg/bin/mem_opt_scratch.f90 +BRAMS/i11dbg/bin/mem_polygons.f90 +BRAMS/i11dbg/bin/mem_radiate.f90 +BRAMS/i11dbg/bin/mem_scalar.f90 +BRAMS/i11dbg/bin/mem_scratch1_brams.f90 +BRAMS/i11dbg/bin/mem_scratch1_grell.f90 +BRAMS/i11dbg/bin/mem_scratch2_grell.f90 +BRAMS/i11dbg/bin/mem_scratch2_grell_sh.f90 +BRAMS/i11dbg/bin/mem_scratch3_grell.f90 +BRAMS/i11dbg/bin/mem_scratch3_grell_sh.f90 +BRAMS/i11dbg/bin/mem_scratch.f90 +BRAMS/i11dbg/bin/mem_scratch_grell.f90 +BRAMS/i11dbg/bin/mem_soil_moisture.f90 +BRAMS/i11dbg/bin/mem_tconv.f90 +BRAMS/i11dbg/bin/mem_teb_common.f90 +BRAMS/i11dbg/bin/mem_teb.f90 +BRAMS/i11dbg/bin/mem_teb_vars_const.f90 +BRAMS/i11dbg/bin/mem_tend.f90 +BRAMS/i11dbg/bin/mem_turb.f90 +BRAMS/i11dbg/bin/mem_turb_scalar.f90 +BRAMS/i11dbg/bin/mem_varinit.f90 +BRAMS/i11dbg/bin/met_driver_coms.f90 +BRAMS/i11dbg/bin/mic_coll.f90 +BRAMS/i11dbg/bin/mic_driv.f90 +BRAMS/i11dbg/bin/mic_gamma.f90 +BRAMS/i11dbg/bin/mic_init.f90 +BRAMS/i11dbg/bin/mic_misc.f90 +BRAMS/i11dbg/bin/mic_nuc.f90 +BRAMS/i11dbg/bin/micphys.f90 +BRAMS/i11dbg/bin/micro_coms.f90 +BRAMS/i11dbg/bin/mic_tabs.f90 +BRAMS/i11dbg/bin/mic_vap.f90 +BRAMS/i11dbg/bin/mksfc_driver.f90 +BRAMS/i11dbg/bin/mksfc_fuso.f90 +BRAMS/i11dbg/bin/mksfc_ndvi.f90 +BRAMS/i11dbg/bin/mksfc_sfc.f90 +BRAMS/i11dbg/bin/mksfc_sst.f90 +BRAMS/i11dbg/bin/mksfc_top.f90 +BRAMS/i11dbg/bin/mnt_advec_aux.f90 +BRAMS/i11dbg/bin/mnt_advec_main.f90 +BRAMS/i11dbg/bin/mod_advect_kit.f90 +BRAMS/i11dbg/bin/model.f90 +BRAMS/i11dbg/bin/mod_GhostBlock.f90 +BRAMS/i11dbg/bin/mod_GhostBlockPartition.f90 +BRAMS/i11dbg/bin/mod_ozone.f90 +BRAMS/i11dbg/bin/modsched.f90 +BRAMS/i11dbg/bin/mortality.f90 +BRAMS/i11dbg/bin/mpass_advec.f90 +BRAMS/i11dbg/bin/mpass_cyclic.f90 +BRAMS/i11dbg/bin/mpass_dtl.f90 +BRAMS/i11dbg/bin/mpass_feed.f90 +BRAMS/i11dbg/bin/mpass_full.f90 +BRAMS/i11dbg/bin/mpass_init.f90 +BRAMS/i11dbg/bin/mpass_lbc.f90 +BRAMS/i11dbg/bin/mpass_nest.f90 +BRAMS/i11dbg/bin/mpass_oda.f90 +BRAMS/i11dbg/bin/mpass_st.f90 +BRAMS/i11dbg/bin/multiple_scatter.f90 +BRAMS/i11dbg/bin/ncarg_dummy.f90 +BRAMS/i11dbg/bin/ndvi_read.f90 +BRAMS/i11dbg/bin/nest_feed.f90 +BRAMS/i11dbg/bin/nest_filldens.f90 +BRAMS/i11dbg/bin/nest_geosst.f90 +BRAMS/i11dbg/bin/nest_init_aux.f90 +BRAMS/i11dbg/bin/nest_intrp.f90 +BRAMS/i11dbg/bin/nest_move.f90 +BRAMS/i11dbg/bin/node_mod.f90 +BRAMS/i11dbg/bin/nud_analysis.f90 +BRAMS/i11dbg/bin/nud_read.f90 +BRAMS/i11dbg/bin/nud_update.f90 +BRAMS/i11dbg/bin/numutils.f90 +BRAMS/i11dbg/bin/obs_input.f90 +BRAMS/i11dbg/bin/oda_krig.f90 +BRAMS/i11dbg/bin/oda_nudge.f90 +BRAMS/i11dbg/bin/oda_proc_obs.f90 +BRAMS/i11dbg/bin/oda_read.f90 +BRAMS/i11dbg/bin/oda_sta_count.f90 +BRAMS/i11dbg/bin/oda_sta_input.f90 +BRAMS/i11dbg/bin/old_grell_cupar_driver.f90 +BRAMS/i11dbg/bin/opspec.f90 +BRAMS/i11dbg/bin/optimiz_coms.f90 +BRAMS/i11dbg/bin/ozone.f90 +BRAMS/i11dbg/bin/para_init.f90 +BRAMS/i11dbg/bin/paral.f90 +BRAMS/i11dbg/bin/par_decomp.f90 +BRAMS/i11dbg/bin/pft_coms.f90 +BRAMS/i11dbg/bin/phenology_aux.f90 +BRAMS/i11dbg/bin/phenology_coms.f90 +BRAMS/i11dbg/bin/phenology_driv.f90 +BRAMS/i11dbg/bin/phenology_startup.f90 +BRAMS/i11dbg/bin/photosyn_driv.f90 +BRAMS/i11dbg/bin/physiology_coms.f90 +BRAMS/i11dbg/bin/plumerise_vector.f90 +BRAMS/i11dbg/bin/polarst.f90 +BRAMS/i11dbg/bin/raco_adap.f90 +BRAMS/i11dbg/bin/raco.f90 +BRAMS/i11dbg/bin/rad_carma.f90 +BRAMS/i11dbg/bin/rad_ccmp.f90 +BRAMS/i11dbg/bin/rad_driv.f90 +BRAMS/i11dbg/bin/radiate_driver.f90 +BRAMS/i11dbg/bin/radiate_utils.f90 +BRAMS/i11dbg/bin/rad_mclat.f90 +BRAMS/i11dbg/bin/rad_stable.f90 +BRAMS/i11dbg/bin/radvc_adap.f90 +BRAMS/i11dbg/bin/radvc.f90 +BRAMS/i11dbg/bin/radvc_new.f90 +BRAMS/i11dbg/bin/rams_grid.f90 +BRAMS/i11dbg/bin/rams_master.f90 +BRAMS/i11dbg/bin/rams_mem_alloc.f90 +BRAMS/i11dbg/bin/rams_read_header.f90 +BRAMS/i11dbg/bin/ranlavg.f90 +BRAMS/i11dbg/bin/rbnd_adap.f90 +BRAMS/i11dbg/bin/rbnd.f90 +BRAMS/i11dbg/bin/rcio.f90 +BRAMS/i11dbg/bin/rconstants.f90 +BRAMS/i11dbg/bin/rconv_driver.f90 +BRAMS/i11dbg/bin/rdint.f90 +BRAMS/i11dbg/bin/read_ralph.f90 +BRAMS/i11dbg/bin/recycle.f90 +BRAMS/i11dbg/bin/ref_sounding.f90 +BRAMS/i11dbg/bin/refstate.f90 +BRAMS/i11dbg/bin/reproduction.f90 +BRAMS/i11dbg/bin/rexev.f90 +BRAMS/i11dbg/bin/rgrad.f90 +BRAMS/i11dbg/bin/rhhi.f90 +BRAMS/i11dbg/bin/rinit.f90 +BRAMS/i11dbg/bin/rio.f90 +BRAMS/i11dbg/bin/rk4_coms.f90 +BRAMS/i11dbg/bin/rk4_integ_utils.f90 +BRAMS/i11dbg/bin/rk4_misc.f90 +BRAMS/i11dbg/bin/rmass.f90 +BRAMS/i11dbg/bin/rname.f90 +BRAMS/i11dbg/bin/rnest_par.f90 +BRAMS/i11dbg/bin/rnode.f90 +BRAMS/i11dbg/bin/rpara.f90 +BRAMS/i11dbg/bin/rprnt.f90 +BRAMS/i11dbg/bin/rthrm.f90 +BRAMS/i11dbg/bin/rtimh.f90 +BRAMS/i11dbg/bin/rtimi.f90 +BRAMS/i11dbg/bin/ruser.f90 +BRAMS/i11dbg/bin/shcu_vars_const.f90 +BRAMS/i11dbg/bin/soil_moisture_init.f90 +BRAMS/i11dbg/bin/soil_respiration.f90 +BRAMS/i11dbg/bin/souza_cupar_driver.f90 +BRAMS/i11dbg/bin/sst_read.f90 +BRAMS/i11dbg/bin/stable_cohorts.f90 +BRAMS/i11dbg/bin/structural_growth.f90 +BRAMS/i11dbg/bin/teb_spm_start.f90 +BRAMS/i11dbg/bin/therm_lib8.f90 +BRAMS/i11dbg/bin/therm_lib.f90 +BRAMS/i11dbg/bin/tkenn.f90 +BRAMS/i11dbg/bin/turb_coms.f90 +BRAMS/i11dbg/bin/turb_derivs.f90 +BRAMS/i11dbg/bin/turb_diff_adap.f90 +BRAMS/i11dbg/bin/turb_diff.f90 +BRAMS/i11dbg/bin/turb_k_adap.f90 +BRAMS/i11dbg/bin/turb_ke.f90 +BRAMS/i11dbg/bin/turb_k.f90 +BRAMS/i11dbg/bin/twostream_rad.f90 +BRAMS/i11dbg/bin/update_derived_props.f90 +BRAMS/i11dbg/bin/urban_canopy.f90 +BRAMS/i11dbg/bin/urban.f90 +BRAMS/i11dbg/bin/utils_f.f90 +BRAMS/i11dbg/bin/varf_read.f90 +BRAMS/i11dbg/bin/varf_update.f90 +BRAMS/i11dbg/bin/var_tables.f90 +BRAMS/i11dbg/bin/varutils.f90 +BRAMS/i11dbg/bin/vegetation_dynamics.f90 +BRAMS/i11dbg/bin/vformat.f90 +BRAMS/i11dbg/bin/v_interps.f90 +BRAMS/i11dbg/bin/vtab_fill.f90 +BRAMS/i11dbg/bin/advect_kit.mod +BRAMS/i11dbg/bin/allometry.mod +BRAMS/i11dbg/bin/an_header.mod +BRAMS/i11dbg/bin/c34constants.mod +BRAMS/i11dbg/bin/canopy_air_coms.mod +BRAMS/i11dbg/bin/canopy_layer_coms.mod +BRAMS/i11dbg/bin/canopy_radiation_coms.mod +BRAMS/i11dbg/bin/canopy_struct_dynamics.mod +BRAMS/i11dbg/bin/catt_start.mod +BRAMS/i11dbg/bin/consts_coms.mod +BRAMS/i11dbg/bin/conv_coms.mod +BRAMS/i11dbg/bin/cyclic_mod.mod +BRAMS/i11dbg/bin/decomp_coms.mod +BRAMS/i11dbg/bin/detailed_coms.mod +BRAMS/i11dbg/bin/disturbance_utils.mod +BRAMS/i11dbg/bin/disturb_coms.mod +BRAMS/i11dbg/bin/domain_decomp.mod +BRAMS/i11dbg/bin/dtset.mod +BRAMS/i11dbg/bin/ed_max_dims.mod +BRAMS/i11dbg/bin/ed_mem_grid_dim_defs.mod +BRAMS/i11dbg/bin/ed_misc_coms.mod +BRAMS/i11dbg/bin/ed_node_coms.mod +BRAMS/i11dbg/bin/ed_para_coms.mod +BRAMS/i11dbg/bin/ed_state_vars.mod +BRAMS/i11dbg/bin/ed_therm_lib.mod +BRAMS/i11dbg/bin/ed_var_tables.mod +BRAMS/i11dbg/bin/ed_work_vars.mod +BRAMS/i11dbg/bin/emission_source_map.mod +BRAMS/i11dbg/bin/ename_coms.mod +BRAMS/i11dbg/bin/extras.mod +BRAMS/i11dbg/bin/farq_leuning.mod +BRAMS/i11dbg/bin/fuse_fiss_utils.mod +BRAMS/i11dbg/bin/fusion_fission_coms.mod +BRAMS/i11dbg/bin/grell_coms.mod +BRAMS/i11dbg/bin/grid_coms.mod +BRAMS/i11dbg/bin/grid_dims.mod +BRAMS/i11dbg/bin/grid_struct.mod +BRAMS/i11dbg/bin/growth_balive.mod +BRAMS/i11dbg/bin/harr_coms.mod +BRAMS/i11dbg/bin/hdf5_coms.mod +BRAMS/i11dbg/bin/hdf5_utils.mod +BRAMS/i11dbg/bin/hydrology_coms.mod +BRAMS/i11dbg/bin/hydrology_constants.mod +BRAMS/i11dbg/bin/io_params.mod +BRAMS/i11dbg/bin/isan_coms.mod +BRAMS/i11dbg/bin/ke_coms.mod +BRAMS/i11dbg/bin/lake_coms.mod +BRAMS/i11dbg/bin/leaf_coms.mod +BRAMS/i11dbg/bin/libxml2f90_interface_module.mod +BRAMS/i11dbg/bin/libxml2f90_module.mod +BRAMS/i11dbg/bin/libxml2f90_strings_module.mod +BRAMS/i11dbg/bin/ll_module.mod +BRAMS/i11dbg/bin/machine_arq.mod +BRAMS/i11dbg/bin/mem_aerad.mod +BRAMS/i11dbg/bin/mem_all.mod +BRAMS/i11dbg/bin/mem_basic.mod +BRAMS/i11dbg/bin/mem_carma.mod +BRAMS/i11dbg/bin/mem_cuparm.mod +BRAMS/i11dbg/bin/mem_edcp.mod +BRAMS/i11dbg/bin/mem_emiss.mod +BRAMS/i11dbg/bin/mem_ensemble.mod +BRAMS/i11dbg/bin/mem_gaspart.mod +BRAMS/i11dbg/bin/mem_globaer.mod +BRAMS/i11dbg/bin/mem_globrad.mod +BRAMS/i11dbg/bin/mem_grell_param.mod +BRAMS/i11dbg/bin/mem_grid_dim_defs.mod +BRAMS/i11dbg/bin/mem_grid.mod +BRAMS/i11dbg/bin/mem_harr.mod +BRAMS/i11dbg/bin/mem_leaf.mod +BRAMS/i11dbg/bin/mem_mass.mod +BRAMS/i11dbg/bin/mem_mclat.mod +BRAMS/i11dbg/bin/mem_micro.mod +BRAMS/i11dbg/bin/mem_mksfc.mod +BRAMS/i11dbg/bin/mem_mnt_advec.mod +BRAMS/i11dbg/bin/mem_nestb.mod +BRAMS/i11dbg/bin/mem_oda.mod +BRAMS/i11dbg/bin/mem_opt.mod +BRAMS/i11dbg/bin/mem_polygons.mod +BRAMS/i11dbg/bin/mem_radiate.mod +BRAMS/i11dbg/bin/mem_scalar.mod +BRAMS/i11dbg/bin/mem_scratch1_grell.mod +BRAMS/i11dbg/bin/mem_scratch1.mod +BRAMS/i11dbg/bin/mem_scratch2_grell.mod +BRAMS/i11dbg/bin/mem_scratch2_grell_sh.mod +BRAMS/i11dbg/bin/mem_scratch3_grell.mod +BRAMS/i11dbg/bin/mem_scratch3_grell_sh.mod +BRAMS/i11dbg/bin/mem_scratch_grell.mod +BRAMS/i11dbg/bin/mem_scratch.mod +BRAMS/i11dbg/bin/mem_soil_moisture.mod +BRAMS/i11dbg/bin/mem_tconv.mod +BRAMS/i11dbg/bin/mem_teb_common.mod +BRAMS/i11dbg/bin/mem_teb.mod +BRAMS/i11dbg/bin/mem_tend.mod +BRAMS/i11dbg/bin/mem_turb.mod +BRAMS/i11dbg/bin/mem_turb_scalar.mod +BRAMS/i11dbg/bin/mem_varinit.mod +BRAMS/i11dbg/bin/met_driver_coms.mod +BRAMS/i11dbg/bin/micphys.mod +BRAMS/i11dbg/bin/micro_coms.mod +BRAMS/i11dbg/bin/mod_ghostblock.mod +BRAMS/i11dbg/bin/mod_ghostblockpartition.mod +BRAMS/i11dbg/bin/mortality.mod +BRAMS/i11dbg/bin/node_mod.mod +BRAMS/i11dbg/bin/obs_input.mod +BRAMS/i11dbg/bin/optimiz_coms.mod +BRAMS/i11dbg/bin/ozone_const.mod +BRAMS/i11dbg/bin/pft_coms.mod +BRAMS/i11dbg/bin/phenology_aux.mod +BRAMS/i11dbg/bin/phenology_coms.mod +BRAMS/i11dbg/bin/phenology_startup.mod +BRAMS/i11dbg/bin/physiology_coms.mod +BRAMS/i11dbg/bin/plume_utils.mod +BRAMS/i11dbg/bin/rad_carma.mod +BRAMS/i11dbg/bin/rconstants.mod +BRAMS/i11dbg/bin/ref_sounding.mod +BRAMS/i11dbg/bin/rk4_coms.mod +BRAMS/i11dbg/bin/rk4_driver.mod +BRAMS/i11dbg/bin/rk4_stepper.mod +BRAMS/i11dbg/bin/rpara.mod +BRAMS/i11dbg/bin/shcu_vars_const.mod +BRAMS/i11dbg/bin/soil_coms.mod +BRAMS/i11dbg/bin/teb_spm_start.mod +BRAMS/i11dbg/bin/teb_vars_const.mod +BRAMS/i11dbg/bin/therm_lib8.mod +BRAMS/i11dbg/bin/therm_lib.mod +BRAMS/i11dbg/bin/turb_coms.mod +BRAMS/i11dbg/bin/var_tables.mod +BRAMS/i11dbg/bin/advect_kit.mod +BRAMS/i11dbg/bin/allometry.mod +BRAMS/i11dbg/bin/an_header.mod +BRAMS/i11dbg/bin/c34constants.mod +BRAMS/i11dbg/bin/canopy_air_coms.mod +BRAMS/i11dbg/bin/canopy_layer_coms.mod +BRAMS/i11dbg/bin/canopy_radiation_coms.mod +BRAMS/i11dbg/bin/canopy_struct_dynamics.mod +BRAMS/i11dbg/bin/catt_start.mod +BRAMS/i11dbg/bin/consts_coms.mod +BRAMS/i11dbg/bin/conv_coms.mod +BRAMS/i11dbg/bin/cyclic_mod.mod +BRAMS/i11dbg/bin/decomp_coms.mod +BRAMS/i11dbg/bin/detailed_coms.mod +BRAMS/i11dbg/bin/disturbance_utils.mod +BRAMS/i11dbg/bin/disturb_coms.mod +BRAMS/i11dbg/bin/domain_decomp.mod +BRAMS/i11dbg/bin/dtset.mod +BRAMS/i11dbg/bin/ed_max_dims.mod +BRAMS/i11dbg/bin/ed_mem_grid_dim_defs.mod +BRAMS/i11dbg/bin/ed_misc_coms.mod +BRAMS/i11dbg/bin/ed_node_coms.mod +BRAMS/i11dbg/bin/ed_para_coms.mod +BRAMS/i11dbg/bin/ed_state_vars.mod +BRAMS/i11dbg/bin/ed_therm_lib.mod +BRAMS/i11dbg/bin/ed_var_tables.mod +BRAMS/i11dbg/bin/ed_work_vars.mod +BRAMS/i11dbg/bin/emission_source_map.mod +BRAMS/i11dbg/bin/ename_coms.mod +BRAMS/i11dbg/bin/extras.mod +BRAMS/i11dbg/bin/farq_leuning.mod +BRAMS/i11dbg/bin/fuse_fiss_utils.mod +BRAMS/i11dbg/bin/fusion_fission_coms.mod +BRAMS/i11dbg/bin/grell_coms.mod +BRAMS/i11dbg/bin/grid_coms.mod +BRAMS/i11dbg/bin/grid_dims.mod +BRAMS/i11dbg/bin/grid_struct.mod +BRAMS/i11dbg/bin/growth_balive.mod +BRAMS/i11dbg/bin/harr_coms.mod +BRAMS/i11dbg/bin/hdf5_coms.mod +BRAMS/i11dbg/bin/hdf5_utils.mod +BRAMS/i11dbg/bin/hydrology_coms.mod +BRAMS/i11dbg/bin/hydrology_constants.mod +BRAMS/i11dbg/bin/io_params.mod +BRAMS/i11dbg/bin/isan_coms.mod +BRAMS/i11dbg/bin/ke_coms.mod +BRAMS/i11dbg/bin/lake_coms.mod +BRAMS/i11dbg/bin/leaf_coms.mod +BRAMS/i11dbg/bin/libxml2f90_interface_module.mod +BRAMS/i11dbg/bin/libxml2f90_module.mod +BRAMS/i11dbg/bin/libxml2f90_strings_module.mod +BRAMS/i11dbg/bin/ll_module.mod +BRAMS/i11dbg/bin/machine_arq.mod +BRAMS/i11dbg/bin/mem_aerad.mod +BRAMS/i11dbg/bin/mem_all.mod +BRAMS/i11dbg/bin/mem_basic.mod +BRAMS/i11dbg/bin/mem_carma.mod +BRAMS/i11dbg/bin/mem_cuparm.mod +BRAMS/i11dbg/bin/mem_edcp.mod +BRAMS/i11dbg/bin/mem_emiss.mod +BRAMS/i11dbg/bin/mem_ensemble.mod +BRAMS/i11dbg/bin/mem_gaspart.mod +BRAMS/i11dbg/bin/mem_globaer.mod +BRAMS/i11dbg/bin/mem_globrad.mod +BRAMS/i11dbg/bin/mem_grell_param.mod +BRAMS/i11dbg/bin/mem_grid_dim_defs.mod +BRAMS/i11dbg/bin/mem_grid.mod +BRAMS/i11dbg/bin/mem_harr.mod +BRAMS/i11dbg/bin/mem_leaf.mod +BRAMS/i11dbg/bin/mem_mass.mod +BRAMS/i11dbg/bin/mem_mclat.mod +BRAMS/i11dbg/bin/mem_micro.mod +BRAMS/i11dbg/bin/mem_mksfc.mod +BRAMS/i11dbg/bin/mem_mnt_advec.mod +BRAMS/i11dbg/bin/mem_nestb.mod +BRAMS/i11dbg/bin/mem_oda.mod +BRAMS/i11dbg/bin/mem_opt.mod +BRAMS/i11dbg/bin/mem_polygons.mod +BRAMS/i11dbg/bin/mem_radiate.mod +BRAMS/i11dbg/bin/mem_scalar.mod +BRAMS/i11dbg/bin/mem_scratch1_grell.mod +BRAMS/i11dbg/bin/mem_scratch1.mod +BRAMS/i11dbg/bin/mem_scratch2_grell.mod +BRAMS/i11dbg/bin/mem_scratch2_grell_sh.mod +BRAMS/i11dbg/bin/mem_scratch3_grell.mod +BRAMS/i11dbg/bin/mem_scratch3_grell_sh.mod +BRAMS/i11dbg/bin/mem_scratch_grell.mod +BRAMS/i11dbg/bin/mem_scratch.mod +BRAMS/i11dbg/bin/mem_soil_moisture.mod +BRAMS/i11dbg/bin/mem_tconv.mod +BRAMS/i11dbg/bin/mem_teb_common.mod +BRAMS/i11dbg/bin/mem_teb.mod +BRAMS/i11dbg/bin/mem_tend.mod +BRAMS/i11dbg/bin/mem_turb.mod +BRAMS/i11dbg/bin/mem_turb_scalar.mod +BRAMS/i11dbg/bin/mem_varinit.mod +BRAMS/i11dbg/bin/met_driver_coms.mod +BRAMS/i11dbg/bin/micphys.mod +BRAMS/i11dbg/bin/micro_coms.mod +BRAMS/i11dbg/bin/mod_ghostblock.mod +BRAMS/i11dbg/bin/mod_ghostblockpartition.mod +BRAMS/i11dbg/bin/mortality.mod +BRAMS/i11dbg/bin/node_mod.mod +BRAMS/i11dbg/bin/obs_input.mod +BRAMS/i11dbg/bin/optimiz_coms.mod +BRAMS/i11dbg/bin/ozone_const.mod +BRAMS/i11dbg/bin/pft_coms.mod +BRAMS/i11dbg/bin/phenology_aux.mod +BRAMS/i11dbg/bin/phenology_coms.mod +BRAMS/i11dbg/bin/phenology_startup.mod +BRAMS/i11dbg/bin/physiology_coms.mod +BRAMS/i11dbg/bin/plume_utils.mod +BRAMS/i11dbg/bin/rad_carma.mod +BRAMS/i11dbg/bin/rconstants.mod +BRAMS/i11dbg/bin/ref_sounding.mod +BRAMS/i11dbg/bin/rk4_coms.mod +BRAMS/i11dbg/bin/rk4_driver.mod +BRAMS/i11dbg/bin/rk4_stepper.mod +BRAMS/i11dbg/bin/rpara.mod +BRAMS/i11dbg/bin/shcu_vars_const.mod +BRAMS/i11dbg/bin/soil_coms.mod +BRAMS/i11dbg/bin/teb_spm_start.mod +BRAMS/i11dbg/bin/teb_vars_const.mod +BRAMS/i11dbg/bin/therm_lib8.mod +BRAMS/i11dbg/bin/therm_lib.mod +BRAMS/i11dbg/bin/turb_coms.mod +BRAMS/i11dbg/bin/var_tables.mod +BRAMS/i11dbg/edbrams-opt +BRAMS/i11dbg/edbrams-opt +BRAMS/i11dbg/edbrams-opt.a +BRAMS/i11dbg/edbrams-opt +BRAMS/i11dbg/bin/advect_kit.mod +BRAMS/i11dbg/bin/allometry.mod +BRAMS/i11dbg/bin/an_header.mod +BRAMS/i11dbg/bin/c34constants.mod +BRAMS/i11dbg/bin/canopy_air_coms.mod +BRAMS/i11dbg/bin/canopy_layer_coms.mod +BRAMS/i11dbg/bin/canopy_radiation_coms.mod +BRAMS/i11dbg/bin/canopy_struct_dynamics.mod +BRAMS/i11dbg/bin/catt_start.mod +BRAMS/i11dbg/bin/consts_coms.mod +BRAMS/i11dbg/bin/conv_coms.mod +BRAMS/i11dbg/bin/cyclic_mod.mod +BRAMS/i11dbg/bin/decomp_coms.mod +BRAMS/i11dbg/bin/detailed_coms.mod +BRAMS/i11dbg/bin/disturbance_utils.mod +BRAMS/i11dbg/bin/disturb_coms.mod +BRAMS/i11dbg/bin/domain_decomp.mod +BRAMS/i11dbg/bin/dtset.mod +BRAMS/i11dbg/bin/ed_max_dims.mod +BRAMS/i11dbg/bin/ed_mem_grid_dim_defs.mod +BRAMS/i11dbg/bin/ed_misc_coms.mod +BRAMS/i11dbg/bin/ed_node_coms.mod +BRAMS/i11dbg/bin/ed_para_coms.mod +BRAMS/i11dbg/bin/ed_state_vars.mod +BRAMS/i11dbg/bin/ed_therm_lib.mod +BRAMS/i11dbg/bin/ed_var_tables.mod +BRAMS/i11dbg/bin/ed_work_vars.mod +BRAMS/i11dbg/bin/emission_source_map.mod +BRAMS/i11dbg/bin/ename_coms.mod +BRAMS/i11dbg/bin/extras.mod +BRAMS/i11dbg/bin/farq_leuning.mod +BRAMS/i11dbg/bin/fuse_fiss_utils.mod +BRAMS/i11dbg/bin/fusion_fission_coms.mod +BRAMS/i11dbg/bin/grell_coms.mod +BRAMS/i11dbg/bin/grid_coms.mod +BRAMS/i11dbg/bin/grid_dims.mod +BRAMS/i11dbg/bin/grid_struct.mod +BRAMS/i11dbg/bin/growth_balive.mod +BRAMS/i11dbg/bin/harr_coms.mod +BRAMS/i11dbg/bin/hdf5_coms.mod +BRAMS/i11dbg/bin/hdf5_utils.mod +BRAMS/i11dbg/bin/hydrology_coms.mod +BRAMS/i11dbg/bin/hydrology_constants.mod +BRAMS/i11dbg/bin/io_params.mod +BRAMS/i11dbg/bin/isan_coms.mod +BRAMS/i11dbg/bin/ke_coms.mod +BRAMS/i11dbg/bin/lake_coms.mod +BRAMS/i11dbg/bin/leaf_coms.mod +BRAMS/i11dbg/bin/libxml2f90_interface_module.mod +BRAMS/i11dbg/bin/libxml2f90_module.mod +BRAMS/i11dbg/bin/libxml2f90_strings_module.mod +BRAMS/i11dbg/bin/ll_module.mod +BRAMS/i11dbg/bin/machine_arq.mod +BRAMS/i11dbg/bin/mem_aerad.mod +BRAMS/i11dbg/bin/mem_all.mod +BRAMS/i11dbg/bin/mem_basic.mod +BRAMS/i11dbg/bin/mem_carma.mod +BRAMS/i11dbg/bin/mem_cuparm.mod +BRAMS/i11dbg/bin/mem_edcp.mod +BRAMS/i11dbg/bin/mem_emiss.mod +BRAMS/i11dbg/bin/mem_ensemble.mod +BRAMS/i11dbg/bin/mem_gaspart.mod +BRAMS/i11dbg/bin/mem_globaer.mod +BRAMS/i11dbg/bin/mem_globrad.mod +BRAMS/i11dbg/bin/mem_grell_param.mod +BRAMS/i11dbg/bin/mem_grid_dim_defs.mod +BRAMS/i11dbg/bin/mem_grid.mod +BRAMS/i11dbg/bin/mem_harr.mod +BRAMS/i11dbg/bin/mem_leaf.mod +BRAMS/i11dbg/bin/mem_mass.mod +BRAMS/i11dbg/bin/mem_mclat.mod +BRAMS/i11dbg/bin/mem_micro.mod +BRAMS/i11dbg/bin/mem_mksfc.mod +BRAMS/i11dbg/bin/mem_mnt_advec.mod +BRAMS/i11dbg/bin/mem_nestb.mod +BRAMS/i11dbg/bin/mem_oda.mod +BRAMS/i11dbg/bin/mem_opt.mod +BRAMS/i11dbg/bin/mem_polygons.mod +BRAMS/i11dbg/bin/mem_radiate.mod +BRAMS/i11dbg/bin/mem_scalar.mod +BRAMS/i11dbg/bin/mem_scratch1_grell.mod +BRAMS/i11dbg/bin/mem_scratch1.mod +BRAMS/i11dbg/bin/mem_scratch2_grell.mod +BRAMS/i11dbg/bin/mem_scratch2_grell_sh.mod +BRAMS/i11dbg/bin/mem_scratch3_grell.mod +BRAMS/i11dbg/bin/mem_scratch3_grell_sh.mod +BRAMS/i11dbg/bin/mem_scratch_grell.mod +BRAMS/i11dbg/bin/mem_scratch.mod +BRAMS/i11dbg/bin/mem_soil_moisture.mod +BRAMS/i11dbg/bin/mem_tconv.mod +BRAMS/i11dbg/bin/mem_teb_common.mod +BRAMS/i11dbg/bin/mem_teb.mod +BRAMS/i11dbg/bin/mem_tend.mod +BRAMS/i11dbg/bin/mem_turb.mod +BRAMS/i11dbg/bin/mem_turb_scalar.mod +BRAMS/i11dbg/bin/mem_varinit.mod +BRAMS/i11dbg/bin/met_driver_coms.mod +BRAMS/i11dbg/bin/micphys.mod +BRAMS/i11dbg/bin/micro_coms.mod +BRAMS/i11dbg/bin/mod_ghostblock.mod +BRAMS/i11dbg/bin/mod_ghostblockpartition.mod +BRAMS/i11dbg/bin/mortality.mod +BRAMS/i11dbg/bin/node_mod.mod +BRAMS/i11dbg/bin/obs_input.mod +BRAMS/i11dbg/bin/optimiz_coms.mod +BRAMS/i11dbg/bin/ozone_const.mod +BRAMS/i11dbg/bin/pft_coms.mod +BRAMS/i11dbg/bin/phenology_aux.mod +BRAMS/i11dbg/bin/phenology_coms.mod +BRAMS/i11dbg/bin/phenology_startup.mod +BRAMS/i11dbg/bin/physiology_coms.mod +BRAMS/i11dbg/bin/plume_utils.mod +BRAMS/i11dbg/bin/rad_carma.mod +BRAMS/i11dbg/bin/rconstants.mod +BRAMS/i11dbg/bin/ref_sounding.mod +BRAMS/i11dbg/bin/rk4_coms.mod +BRAMS/i11dbg/bin/rk4_driver.mod +BRAMS/i11dbg/bin/rk4_stepper.mod +BRAMS/i11dbg/bin/rpara.mod +BRAMS/i11dbg/bin/shcu_vars_const.mod +BRAMS/i11dbg/bin/soil_coms.mod +BRAMS/i11dbg/bin/teb_spm_start.mod +BRAMS/i11dbg/bin/teb_vars_const.mod +BRAMS/i11dbg/bin/therm_lib8.mod +BRAMS/i11dbg/bin/therm_lib.mod +BRAMS/i11dbg/bin/turb_coms.mod +BRAMS/i11dbg/bin/var_tables.mod +BRAMS/i11dbg/bin/adap_init.f90 +BRAMS/i11dbg/bin/allometry.f90 +BRAMS/i11dbg/bin/altera_dia.f90 +BRAMS/i11dbg/bin/an_header.f90 +BRAMS/i11dbg/bin/aobj.f90 +BRAMS/i11dbg/bin/asgen.f90 +BRAMS/i11dbg/bin/asti2.f90 +BRAMS/i11dbg/bin/asti.f90 +BRAMS/i11dbg/bin/astp.f90 +BRAMS/i11dbg/bin/avarf.f90 +BRAMS/i11dbg/bin/average_utils.f90 +BRAMS/i11dbg/bin/bdf2_solver.f90 +BRAMS/i11dbg/bin/budget_utils.f90 +BRAMS/i11dbg/bin/c34constants.f90 +BRAMS/i11dbg/bin/canopy_air_coms.f90 +BRAMS/i11dbg/bin/canopy_radiation_coms.f90 +BRAMS/i11dbg/bin/canopy_struct_dynamics.f90 +BRAMS/i11dbg/bin/catt_start.f90 +BRAMS/i11dbg/bin/charutils.f90 +BRAMS/i11dbg/bin/cond_read.f90 +BRAMS/i11dbg/bin/cond_update.f90 +BRAMS/i11dbg/bin/conv_coms.f90 +BRAMS/i11dbg/bin/coriolis.f90 +BRAMS/i11dbg/bin/cup_dn.f90 +BRAMS/i11dbg/bin/cup_env.f90 +BRAMS/i11dbg/bin/cup_grell2.f90 +BRAMS/i11dbg/bin/cup_grell2_shcu.f90 +BRAMS/i11dbg/bin/cup_up.f90 +BRAMS/i11dbg/bin/cu_read.f90 +BRAMS/i11dbg/bin/cyclic_mod.f90 +BRAMS/i11dbg/bin/dateutils.f90 +BRAMS/i11dbg/bin/dealloc.f90 +BRAMS/i11dbg/bin/decomp_coms.f90 +BRAMS/i11dbg/bin/detailed_coms.f90 +BRAMS/i11dbg/bin/diffsclr.f90 +BRAMS/i11dbg/bin/diffuse.f90 +BRAMS/i11dbg/bin/disturbance.f90 +BRAMS/i11dbg/bin/disturb_coms.f90 +BRAMS/i11dbg/bin/domain_decomp.f90 +BRAMS/i11dbg/bin/dry_dep.f90 +BRAMS/i11dbg/bin/edcp_driver.f90 +BRAMS/i11dbg/bin/edcp_init.f90 +BRAMS/i11dbg/bin/edcp_lake_driver.f90 +BRAMS/i11dbg/bin/edcp_lake_misc.f90 +BRAMS/i11dbg/bin/edcp_lake_stepper.f90 +BRAMS/i11dbg/bin/edcp_load_namelist.f90 +BRAMS/i11dbg/bin/edcp_met.f90 +BRAMS/i11dbg/bin/edcp_met_init.f90 +BRAMS/i11dbg/bin/edcp_model.f90 +BRAMS/i11dbg/bin/edcp_mpiutils.f90 +BRAMS/i11dbg/bin/edcp_para_init.f90 +BRAMS/i11dbg/bin/ed_grid.f90 +BRAMS/i11dbg/bin/ed_init.f90 +BRAMS/i11dbg/bin/edio.f90 +BRAMS/i11dbg/bin/ed_mem_grid_dim_defs.f90 +BRAMS/i11dbg/bin/ed_misc_coms.f90 +BRAMS/i11dbg/bin/ed_nbg_init.f90 +BRAMS/i11dbg/bin/ed_node_coms.f90 +BRAMS/i11dbg/bin/ed_para_coms.f90 +BRAMS/i11dbg/bin/ed_params.f90 +BRAMS/i11dbg/bin/ed_print.f90 +BRAMS/i11dbg/bin/ed_read_ed10_20_history.f90 +BRAMS/i11dbg/bin/ed_state_vars.f90 +BRAMS/i11dbg/bin/ed_therm_lib.f90 +BRAMS/i11dbg/bin/ed_type_init.f90 +BRAMS/i11dbg/bin/ed_var_tables.f90 +BRAMS/i11dbg/bin/ed_work_vars.f90 +BRAMS/i11dbg/bin/ed_xml_config.f90 +BRAMS/i11dbg/bin/emission_source_map.f90 +BRAMS/i11dbg/bin/ename_coms.f90 +BRAMS/i11dbg/bin/error_mess.f90 +BRAMS/i11dbg/bin/euler_driver.f90 +BRAMS/i11dbg/bin/events.f90 +BRAMS/i11dbg/bin/extra.f90 +BRAMS/i11dbg/bin/farq_leuning.f90 +BRAMS/i11dbg/bin/fatal_error.f90 +BRAMS/i11dbg/bin/file_inv.f90 +BRAMS/i11dbg/bin/fire.f90 +BRAMS/i11dbg/bin/first_rams.f90 +BRAMS/i11dbg/bin/forestry.f90 +BRAMS/i11dbg/bin/fuse_fiss_utils.f90 +BRAMS/i11dbg/bin/fusion_fission_coms.f90 +BRAMS/i11dbg/bin/gaspart.f90 +BRAMS/i11dbg/bin/geodat.f90 +BRAMS/i11dbg/bin/getvar.f90 +BRAMS/i11dbg/bin/great_circle.f90 +BRAMS/i11dbg/bin/grell_coms.f90 +BRAMS/i11dbg/bin/grell_cupar_aux.f90 +BRAMS/i11dbg/bin/grell_cupar_downdraft.f90 +BRAMS/i11dbg/bin/grell_cupar_driver.f90 +BRAMS/i11dbg/bin/grell_cupar_dynamic.f90 +BRAMS/i11dbg/bin/grell_cupar_ensemble.f90 +BRAMS/i11dbg/bin/grell_cupar_environment.f90 +BRAMS/i11dbg/bin/grell_cupar_feedback.f90 +BRAMS/i11dbg/bin/grell_cupar_static.f90 +BRAMS/i11dbg/bin/grell_cupar_updraft.f90 +BRAMS/i11dbg/bin/grell_extras_catt.f90 +BRAMS/i11dbg/bin/grid_coms.f90 +BRAMS/i11dbg/bin/grid_dims.f90 +BRAMS/i11dbg/bin/gridset.f90 +BRAMS/i11dbg/bin/grid_struct.f90 +BRAMS/i11dbg/bin/growth_balive.f90 +BRAMS/i11dbg/bin/harr_coms.f90 +BRAMS/i11dbg/bin/harr_raddriv.f90 +BRAMS/i11dbg/bin/harr_radinit.f90 +BRAMS/i11dbg/bin/hemi2.f90 +BRAMS/i11dbg/bin/heun_driver.f90 +BRAMS/i11dbg/bin/htint-opt.f90 +BRAMS/i11dbg/bin/hybrid_driver.f90 +BRAMS/i11dbg/bin/hydrology_coms.f90 +BRAMS/i11dbg/bin/hydrology_constants.f90 +BRAMS/i11dbg/bin/inithis.f90 +BRAMS/i11dbg/bin/init_hydro_sites.f90 +BRAMS/i11dbg/bin/interp_lib.f90 +BRAMS/i11dbg/bin/invmondays.f90 +BRAMS/i11dbg/bin/io_params.f90 +BRAMS/i11dbg/bin/isan_coms.f90 +BRAMS/i11dbg/bin/isan_io.f90 +BRAMS/i11dbg/bin/ke_coms.f90 +BRAMS/i11dbg/bin/kuo_cupar_driver.f90 +BRAMS/i11dbg/bin/lake_coms.f90 +BRAMS/i11dbg/bin/landuse_init.f90 +BRAMS/i11dbg/bin/lapse.f90 +BRAMS/i11dbg/bin/leaf3_bc.f90 +BRAMS/i11dbg/bin/leaf3_can.f90 +BRAMS/i11dbg/bin/leaf3.f90 +BRAMS/i11dbg/bin/leaf3_hyd.f90 +BRAMS/i11dbg/bin/leaf3_init.f90 +BRAMS/i11dbg/bin/leaf3_ocean.f90 +BRAMS/i11dbg/bin/leaf3_teb.f90 +BRAMS/i11dbg/bin/leaf3_tw.f90 +BRAMS/i11dbg/bin/leaf3_utils.f90 +BRAMS/i11dbg/bin/leaf_coms.f90 +BRAMS/i11dbg/bin/leaf_database.f90 +BRAMS/i11dbg/bin/libxml2f90.f90_pp.f90 +BRAMS/i11dbg/bin/local_proc.f90 +BRAMS/i11dbg/bin/lsm_hyd.f90 +BRAMS/i11dbg/bin/map_proj.f90 +BRAMS/i11dbg/bin/mem_aerad.f90 +BRAMS/i11dbg/bin/mem_all.f90 +BRAMS/i11dbg/bin/mem_basic.f90 +BRAMS/i11dbg/bin/mem_carma.f90 +BRAMS/i11dbg/bin/mem_cuparm.f90 +BRAMS/i11dbg/bin/mem_edcp.f90 +BRAMS/i11dbg/bin/mem_emiss.f90 +BRAMS/i11dbg/bin/mem_ensemble.f90 +BRAMS/i11dbg/bin/mem_gaspart.f90 +BRAMS/i11dbg/bin/mem_globaer.f90 +BRAMS/i11dbg/bin/mem_globrad.f90 +BRAMS/i11dbg/bin/mem_grell_param2.f90 +BRAMS/i11dbg/bin/mem_grid_dim_defs.f90 +BRAMS/i11dbg/bin/mem_grid.f90 +BRAMS/i11dbg/bin/mem_harr.f90 +BRAMS/i11dbg/bin/mem_leaf.f90 +BRAMS/i11dbg/bin/mem_mass.f90 +BRAMS/i11dbg/bin/mem_mclat.f90 +BRAMS/i11dbg/bin/mem_micro.f90 +BRAMS/i11dbg/bin/mem_mksfc.f90 +BRAMS/i11dbg/bin/mem_mnt_advec.f90 +BRAMS/i11dbg/bin/mem_nestb.f90 +BRAMS/i11dbg/bin/mem_oda.f90 +BRAMS/i11dbg/bin/mem_opt_scratch.f90 +BRAMS/i11dbg/bin/mem_polygons.f90 +BRAMS/i11dbg/bin/mem_radiate.f90 +BRAMS/i11dbg/bin/mem_scalar.f90 +BRAMS/i11dbg/bin/mem_scratch1_brams.f90 +BRAMS/i11dbg/bin/mem_scratch1_grell.f90 +BRAMS/i11dbg/bin/mem_scratch2_grell.f90 +BRAMS/i11dbg/bin/mem_scratch2_grell_sh.f90 +BRAMS/i11dbg/bin/mem_scratch3_grell.f90 +BRAMS/i11dbg/bin/mem_scratch3_grell_sh.f90 +BRAMS/i11dbg/bin/mem_scratch.f90 +BRAMS/i11dbg/bin/mem_scratch_grell.f90 +BRAMS/i11dbg/bin/mem_soil_moisture.f90 +BRAMS/i11dbg/bin/mem_tconv.f90 +BRAMS/i11dbg/bin/mem_teb_common.f90 +BRAMS/i11dbg/bin/mem_teb.f90 +BRAMS/i11dbg/bin/mem_teb_vars_const.f90 +BRAMS/i11dbg/bin/mem_tend.f90 +BRAMS/i11dbg/bin/mem_turb.f90 +BRAMS/i11dbg/bin/mem_turb_scalar.f90 +BRAMS/i11dbg/bin/mem_varinit.f90 +BRAMS/i11dbg/bin/met_driver_coms.f90 +BRAMS/i11dbg/bin/mic_coll.f90 +BRAMS/i11dbg/bin/mic_driv.f90 +BRAMS/i11dbg/bin/mic_gamma.f90 +BRAMS/i11dbg/bin/mic_init.f90 +BRAMS/i11dbg/bin/mic_misc.f90 +BRAMS/i11dbg/bin/mic_nuc.f90 +BRAMS/i11dbg/bin/micphys.f90 +BRAMS/i11dbg/bin/micro_coms.f90 +BRAMS/i11dbg/bin/mic_tabs.f90 +BRAMS/i11dbg/bin/mic_vap.f90 +BRAMS/i11dbg/bin/mksfc_driver.f90 +BRAMS/i11dbg/bin/mksfc_fuso.f90 +BRAMS/i11dbg/bin/mksfc_ndvi.f90 +BRAMS/i11dbg/bin/mksfc_sfc.f90 +BRAMS/i11dbg/bin/mksfc_sst.f90 +BRAMS/i11dbg/bin/mksfc_top.f90 +BRAMS/i11dbg/bin/mnt_advec_aux.f90 +BRAMS/i11dbg/bin/mnt_advec_main.f90 +BRAMS/i11dbg/bin/mod_advect_kit.f90 +BRAMS/i11dbg/bin/model.f90 +BRAMS/i11dbg/bin/mod_GhostBlock.f90 +BRAMS/i11dbg/bin/mod_GhostBlockPartition.f90 +BRAMS/i11dbg/bin/mod_ozone.f90 +BRAMS/i11dbg/bin/modsched.f90 +BRAMS/i11dbg/bin/mortality.f90 +BRAMS/i11dbg/bin/mpass_advec.f90 +BRAMS/i11dbg/bin/mpass_cyclic.f90 +BRAMS/i11dbg/bin/mpass_dtl.f90 +BRAMS/i11dbg/bin/mpass_feed.f90 +BRAMS/i11dbg/bin/mpass_full.f90 +BRAMS/i11dbg/bin/mpass_init.f90 +BRAMS/i11dbg/bin/mpass_lbc.f90 +BRAMS/i11dbg/bin/mpass_nest.f90 +BRAMS/i11dbg/bin/mpass_oda.f90 +BRAMS/i11dbg/bin/mpass_st.f90 +BRAMS/i11dbg/bin/multiple_scatter.f90 +BRAMS/i11dbg/bin/ncarg_dummy.f90 +BRAMS/i11dbg/bin/ndvi_read.f90 +BRAMS/i11dbg/bin/nest_feed.f90 +BRAMS/i11dbg/bin/nest_filldens.f90 +BRAMS/i11dbg/bin/nest_geosst.f90 +BRAMS/i11dbg/bin/nest_init_aux.f90 +BRAMS/i11dbg/bin/nest_intrp.f90 +BRAMS/i11dbg/bin/nest_move.f90 +BRAMS/i11dbg/bin/node_mod.f90 +BRAMS/i11dbg/bin/nud_analysis.f90 +BRAMS/i11dbg/bin/nud_read.f90 +BRAMS/i11dbg/bin/nud_update.f90 +BRAMS/i11dbg/bin/numutils.f90 +BRAMS/i11dbg/bin/obs_input.f90 +BRAMS/i11dbg/bin/oda_krig.f90 +BRAMS/i11dbg/bin/oda_nudge.f90 +BRAMS/i11dbg/bin/oda_proc_obs.f90 +BRAMS/i11dbg/bin/oda_read.f90 +BRAMS/i11dbg/bin/oda_sta_count.f90 +BRAMS/i11dbg/bin/oda_sta_input.f90 +BRAMS/i11dbg/bin/old_grell_cupar_driver.f90 +BRAMS/i11dbg/bin/opspec.f90 +BRAMS/i11dbg/bin/optimiz_coms.f90 +BRAMS/i11dbg/bin/ozone.f90 +BRAMS/i11dbg/bin/para_init.f90 +BRAMS/i11dbg/bin/paral.f90 +BRAMS/i11dbg/bin/par_decomp.f90 +BRAMS/i11dbg/bin/pft_coms.f90 +BRAMS/i11dbg/bin/phenology_aux.f90 +BRAMS/i11dbg/bin/phenology_coms.f90 +BRAMS/i11dbg/bin/phenology_driv.f90 +BRAMS/i11dbg/bin/phenology_startup.f90 +BRAMS/i11dbg/bin/photosyn_driv.f90 +BRAMS/i11dbg/bin/physiology_coms.f90 +BRAMS/i11dbg/bin/plumerise_vector.f90 +BRAMS/i11dbg/bin/polarst.f90 +BRAMS/i11dbg/bin/raco_adap.f90 +BRAMS/i11dbg/bin/raco.f90 +BRAMS/i11dbg/bin/rad_carma.f90 +BRAMS/i11dbg/bin/rad_ccmp.f90 +BRAMS/i11dbg/bin/rad_driv.f90 +BRAMS/i11dbg/bin/radiate_driver.f90 +BRAMS/i11dbg/bin/radiate_utils.f90 +BRAMS/i11dbg/bin/rad_mclat.f90 +BRAMS/i11dbg/bin/rad_stable.f90 +BRAMS/i11dbg/bin/radvc_adap.f90 +BRAMS/i11dbg/bin/radvc.f90 +BRAMS/i11dbg/bin/radvc_new.f90 +BRAMS/i11dbg/bin/rams_grid.f90 +BRAMS/i11dbg/bin/rams_master.f90 +BRAMS/i11dbg/bin/rams_mem_alloc.f90 +BRAMS/i11dbg/bin/rams_read_header.f90 +BRAMS/i11dbg/bin/ranlavg.f90 +BRAMS/i11dbg/bin/rbnd_adap.f90 +BRAMS/i11dbg/bin/rbnd.f90 +BRAMS/i11dbg/bin/rcio.f90 +BRAMS/i11dbg/bin/rconstants.f90 +BRAMS/i11dbg/bin/rconv_driver.f90 +BRAMS/i11dbg/bin/rdint.f90 +BRAMS/i11dbg/bin/read_ralph.f90 +BRAMS/i11dbg/bin/recycle.f90 +BRAMS/i11dbg/bin/ref_sounding.f90 +BRAMS/i11dbg/bin/refstate.f90 +BRAMS/i11dbg/bin/reproduction.f90 +BRAMS/i11dbg/bin/rexev.f90 +BRAMS/i11dbg/bin/rgrad.f90 +BRAMS/i11dbg/bin/rhhi.f90 +BRAMS/i11dbg/bin/rinit.f90 +BRAMS/i11dbg/bin/rio.f90 +BRAMS/i11dbg/bin/rk4_coms.f90 +BRAMS/i11dbg/bin/rk4_integ_utils.f90 +BRAMS/i11dbg/bin/rk4_misc.f90 +BRAMS/i11dbg/bin/rmass.f90 +BRAMS/i11dbg/bin/rname.f90 +BRAMS/i11dbg/bin/rnest_par.f90 +BRAMS/i11dbg/bin/rnode.f90 +BRAMS/i11dbg/bin/rpara.f90 +BRAMS/i11dbg/bin/rprnt.f90 +BRAMS/i11dbg/bin/rthrm.f90 +BRAMS/i11dbg/bin/rtimh.f90 +BRAMS/i11dbg/bin/rtimi.f90 +BRAMS/i11dbg/bin/ruser.f90 +BRAMS/i11dbg/bin/shcu_vars_const.f90 +BRAMS/i11dbg/bin/soil_moisture_init.f90 +BRAMS/i11dbg/bin/soil_respiration.f90 +BRAMS/i11dbg/bin/souza_cupar_driver.f90 +BRAMS/i11dbg/bin/sst_read.f90 +BRAMS/i11dbg/bin/stable_cohorts.f90 +BRAMS/i11dbg/bin/structural_growth.f90 +BRAMS/i11dbg/bin/teb_spm_start.f90 +BRAMS/i11dbg/bin/therm_lib8.f90 +BRAMS/i11dbg/bin/therm_lib.f90 +BRAMS/i11dbg/bin/tkenn.f90 +BRAMS/i11dbg/bin/turb_coms.f90 +BRAMS/i11dbg/bin/turb_derivs.f90 +BRAMS/i11dbg/bin/turb_diff_adap.f90 +BRAMS/i11dbg/bin/turb_diff.f90 +BRAMS/i11dbg/bin/turb_k_adap.f90 +BRAMS/i11dbg/bin/turb_ke.f90 +BRAMS/i11dbg/bin/turb_k.f90 +BRAMS/i11dbg/bin/twostream_rad.f90 +BRAMS/i11dbg/bin/update_derived_props.f90 +BRAMS/i11dbg/bin/urban_canopy.f90 +BRAMS/i11dbg/bin/urban.f90 +BRAMS/i11dbg/bin/utils_f.f90 +BRAMS/i11dbg/bin/varf_read.f90 +BRAMS/i11dbg/bin/varf_update.f90 +BRAMS/i11dbg/bin/var_tables.f90 +BRAMS/i11dbg/bin/varutils.f90 +BRAMS/i11dbg/bin/vegetation_dynamics.f90 +BRAMS/i11dbg/bin/vformat.f90 +BRAMS/i11dbg/bin/v_interps.f90 +BRAMS/i11dbg/bin/vtab_fill.f90 +BRAMS/i11dbg/bin/asnc.F90 +BRAMS/i11dbg/bin/consts_coms.F90 +BRAMS/i11dbg/bin/ed_filelist.F90 +BRAMS/i11dbg/bin/ed_init_atm.F90 +BRAMS/i11dbg/bin/ed_init_full_history.F90 +BRAMS/i11dbg/bin/ed_max_dims.F90 +BRAMS/i11dbg/bin/ed_opspec.F90 +BRAMS/i11dbg/bin/ed_read_ed21_history.F90 +BRAMS/i11dbg/bin/filelist.F90 +BRAMS/i11dbg/bin/h5_output.F90 +BRAMS/i11dbg/bin/harr_rad.F90 +BRAMS/i11dbg/bin/hdf5_coms.F90 +BRAMS/i11dbg/bin/hdf5_utils.F90 +BRAMS/i11dbg/bin/landuse_input.F90 +BRAMS/i11dbg/bin/machine_arq.F90 +BRAMS/i11dbg/bin/nest_drivers.F90 +BRAMS/i11dbg/bin/rhdf5.F90 +BRAMS/i11dbg/bin/rk4_derivs.F90 +BRAMS/i11dbg/bin/rk4_driver.F90 +BRAMS/i11dbg/bin/rk4_stepper.F90 +BRAMS/i11dbg/bin/rsys.F90 +BRAMS/i11dbg/bin/soil_coms.F90 +BRAMS/build/bin/advect_kit.mod +BRAMS/build/bin/allometry.mod +BRAMS/build/bin/an_header.mod +BRAMS/build/bin/c34constants.mod +BRAMS/build/bin/canopy_air_coms.mod +BRAMS/build/bin/canopy_layer_coms.mod +BRAMS/build/bin/canopy_radiation_coms.mod +BRAMS/build/bin/canopy_struct_dynamics.mod +BRAMS/build/bin/catt_start.mod +BRAMS/build/bin/consts_coms.mod +BRAMS/build/bin/conv_coms.mod +BRAMS/build/bin/cyclic_mod.mod +BRAMS/build/bin/decomp_coms.mod +BRAMS/build/bin/detailed_coms.mod +BRAMS/build/bin/disturbance_utils.mod +BRAMS/build/bin/disturb_coms.mod +BRAMS/build/bin/domain_decomp.mod +BRAMS/build/bin/dtset.mod +BRAMS/build/bin/ed_max_dims.mod +BRAMS/build/bin/ed_mem_grid_dim_defs.mod +BRAMS/build/bin/ed_misc_coms.mod +BRAMS/build/bin/ed_node_coms.mod +BRAMS/build/bin/ed_para_coms.mod +BRAMS/build/bin/ed_state_vars.mod +BRAMS/build/bin/ed_therm_lib.mod +BRAMS/build/bin/ed_var_tables.mod +BRAMS/build/bin/ed_work_vars.mod +BRAMS/build/bin/emission_source_map.mod +BRAMS/build/bin/ename_coms.mod +BRAMS/build/bin/extras.mod +BRAMS/build/bin/farq_leuning.mod +BRAMS/build/bin/fuse_fiss_utils.mod +BRAMS/build/bin/fusion_fission_coms.mod +BRAMS/build/bin/grell_coms.mod +BRAMS/build/bin/grid_coms.mod +BRAMS/build/bin/grid_dims.mod +BRAMS/build/bin/grid_struct.mod +BRAMS/build/bin/growth_balive.mod +BRAMS/build/bin/harr_coms.mod +BRAMS/build/bin/hdf5_coms.mod +BRAMS/build/bin/hdf5_utils.mod +BRAMS/build/bin/hydrology_coms.mod +BRAMS/build/bin/hydrology_constants.mod +BRAMS/build/bin/io_params.mod +BRAMS/build/bin/isan_coms.mod +BRAMS/build/bin/ke_coms.mod +BRAMS/build/bin/lake_coms.mod +BRAMS/build/bin/leaf_coms.mod +BRAMS/build/bin/libxml2f90_interface_module.mod +BRAMS/build/bin/libxml2f90_module.mod +BRAMS/build/bin/libxml2f90_strings_module.mod +BRAMS/build/bin/ll_module.mod +BRAMS/build/bin/machine_arq.mod +BRAMS/build/bin/mem_aerad.mod +BRAMS/build/bin/mem_all.mod +BRAMS/build/bin/mem_basic.mod +BRAMS/build/bin/mem_carma.mod +BRAMS/build/bin/mem_cuparm.mod +BRAMS/build/bin/mem_edcp.mod +BRAMS/build/bin/mem_emiss.mod +BRAMS/build/bin/mem_ensemble.mod +BRAMS/build/bin/mem_gaspart.mod +BRAMS/build/bin/mem_globaer.mod +BRAMS/build/bin/mem_globrad.mod +BRAMS/build/bin/mem_grell_param.mod +BRAMS/build/bin/mem_grid_dim_defs.mod +BRAMS/build/bin/mem_grid.mod +BRAMS/build/bin/mem_harr.mod +BRAMS/build/bin/mem_leaf.mod +BRAMS/build/bin/mem_mass.mod +BRAMS/build/bin/mem_mclat.mod +BRAMS/build/bin/mem_micro.mod +BRAMS/build/bin/mem_mksfc.mod +BRAMS/build/bin/mem_mnt_advec.mod +BRAMS/build/bin/mem_nestb.mod +BRAMS/build/bin/mem_oda.mod +BRAMS/build/bin/mem_opt.mod +BRAMS/build/bin/mem_polygons.mod +BRAMS/build/bin/mem_radiate.mod +BRAMS/build/bin/mem_scalar.mod +BRAMS/build/bin/mem_scratch1_grell.mod +BRAMS/build/bin/mem_scratch1.mod +BRAMS/build/bin/mem_scratch2_grell.mod +BRAMS/build/bin/mem_scratch2_grell_sh.mod +BRAMS/build/bin/mem_scratch3_grell.mod +BRAMS/build/bin/mem_scratch3_grell_sh.mod +BRAMS/build/bin/mem_scratch_grell.mod +BRAMS/build/bin/mem_scratch.mod +BRAMS/build/bin/mem_soil_moisture.mod +BRAMS/build/bin/mem_tconv.mod +BRAMS/build/bin/mem_teb_common.mod +BRAMS/build/bin/mem_teb.mod +BRAMS/build/bin/mem_tend.mod +BRAMS/build/bin/mem_turb.mod +BRAMS/build/bin/mem_turb_scalar.mod +BRAMS/build/bin/mem_varinit.mod +BRAMS/build/bin/met_driver_coms.mod +BRAMS/build/bin/micphys.mod +BRAMS/build/bin/micro_coms.mod +BRAMS/build/bin/mod_ghostblock.mod +BRAMS/build/bin/mod_ghostblockpartition.mod +BRAMS/build/bin/mortality.mod +BRAMS/build/bin/node_mod.mod +BRAMS/build/bin/obs_input.mod +BRAMS/build/bin/optimiz_coms.mod +BRAMS/build/bin/ozone_const.mod +BRAMS/build/bin/pft_coms.mod +BRAMS/build/bin/phenology_aux.mod +BRAMS/build/bin/phenology_coms.mod +BRAMS/build/bin/phenology_startup.mod +BRAMS/build/bin/physiology_coms.mod +BRAMS/build/bin/plume_utils.mod +BRAMS/build/bin/rad_carma.mod +BRAMS/build/bin/rconstants.mod +BRAMS/build/bin/ref_sounding.mod +BRAMS/build/bin/rk4_coms.mod +BRAMS/build/bin/rk4_driver.mod +BRAMS/build/bin/rk4_stepper.mod +BRAMS/build/bin/rpara.mod +BRAMS/build/bin/shcu_vars_const.mod +BRAMS/build/bin/soil_coms.mod +BRAMS/build/bin/teb_spm_start.mod +BRAMS/build/bin/teb_vars_const.mod +BRAMS/build/bin/therm_lib8.mod +BRAMS/build/bin/therm_lib.mod +BRAMS/build/bin/turb_coms.mod +BRAMS/build/bin/var_tables.mod +BRAMS/i11dbg/bin/dted.c +BRAMS/i11dbg/bin/eenviron.c +BRAMS/i11dbg/bin/tmpname.c +BRAMS/i11dbg/bin/utils_c.c +BRAMS/src/lib/dted.c.pdb +BRAMS/src/lib/utils_c.c.pdb +ED/build/bin/allometry.mod +ED/build/bin/an_header.mod +ED/build/bin/c34constants.mod +ED/build/bin/canopy_air_coms.mod +ED/build/bin/canopy_layer_coms.mod +ED/build/bin/canopy_radiation_coms.mod +ED/build/bin/canopy_struct_dynamics.mod +ED/build/bin/consts_coms.mod +ED/build/bin/decomp_coms.mod +ED/build/bin/detailed_coms.mod +ED/build/bin/disturbance_utils.mod +ED/build/bin/disturb_coms.mod +ED/build/bin/ed_max_dims.mod +ED/build/bin/ed_mem_grid_dim_defs.mod +ED/build/bin/ed_misc_coms.mod +ED/build/bin/ed_node_coms.mod +ED/build/bin/ed_para_coms.mod +ED/build/bin/ed_state_vars.mod +ED/build/bin/ed_therm_lib.mod +ED/build/bin/ed_var_tables.mod +ED/build/bin/ed_work_vars.mod +ED/build/bin/ename_coms.mod +ED/build/bin/farq_leuning.mod +ED/build/bin/fuse_fiss_utils.mod +ED/build/bin/fusion_fission_coms.mod +ED/build/bin/grid_coms.mod +ED/build/bin/growth_balive.mod +ED/build/bin/hdf5_coms.mod +ED/build/bin/hdf5_utils.mod +ED/build/bin/hydrology_coms.mod +ED/build/bin/hydrology_constants.mod +ED/build/bin/libxml2f90_interface_module.mod +ED/build/bin/libxml2f90_module.mod +ED/build/bin/libxml2f90_strings_module.mod +ED/build/bin/ll_module.mod +ED/build/bin/mem_polygons.mod +ED/build/bin/met_driver_coms.mod +ED/build/bin/mortality.mod +ED/build/bin/optimiz_coms.mod +ED/build/bin/pft_coms.mod +ED/build/bin/phenology_aux.mod +ED/build/bin/phenology_coms.mod +ED/build/bin/phenology_startup.mod +ED/build/bin/physiology_coms.mod +ED/build/bin/rk4_coms.mod +ED/build/bin/rk4_driver.mod +ED/build/bin/rk4_stepper.mod +ED/build/bin/soil_coms.mod +ED/build/bin/therm_lib8.mod +ED/build/bin/therm_lib.mod +ED/dbgbuild/bin/a3e0_mod.mod +ED/dbgbuild/bin/a3e1_mod.mod +ED/dbgbuild/bin/a3e2_mod.mod +ED/dbgbuild/bin/accum_mod.mod +ED/dbgbuild/bin/acnst_mod.mod +ED/dbgbuild/bin/adivb_mod.mod +ED/dbgbuild/bin/adjust_sfcw_properties_mod.mod +ED/dbgbuild/bin/adjust_topsoil_properties_mod.mod +ED/dbgbuild/bin/adjust_veg_properties_mod.mod +ED/dbgbuild/bin/ae0_mod.mod +ED/dbgbuild/bin/ae1m1_mod.mod +ED/dbgbuild/bin/ae1_mod.mod +ED/dbgbuild/bin/ae1p1_mod.mod +ED/dbgbuild/bin/ae1p1p1_mod.mod +ED/dbgbuild/bin/ae1t0_mod.mod +ED/dbgbuild/bin/ae1t0p1_mod.mod +ED/dbgbuild/bin/ae1t1_mod.mod +ED/dbgbuild/bin/ae1t1p1_mod.mod +ED/dbgbuild/bin/ae1tn1_mod.mod +ED/dbgbuild/bin/ae2_mod.mod +ED/dbgbuild/bin/ae3m3d0_mod.mod +ED/dbgbuild/bin/ae3m3_mod.mod +ED/dbgbuild/bin/ae3_mod.mod +ED/dbgbuild/bin/ae3p3_mod.mod +ED/dbgbuild/bin/ae3t0p3_mod.mod +ED/dbgbuild/bin/ae3t3_mod.mod +ED/dbgbuild/bin/ae3t3p3_mod.mod +ED/dbgbuild/bin/aen1_mod.mod +ED/dbgbuild/bin/aen3t0p3_mod.mod +ED/dbgbuild/bin/alebl_mod.mod +ED/dbgbuild/bin/allometry.mod +ED/dbgbuild/bin/angle_of_incid_mod.mod +ED/dbgbuild/bin/an_header.mod +ED/dbgbuild/bin/aone2_mod.mod +ED/dbgbuild/bin/aone3_mod.mod +ED/dbgbuild/bin/aone4_mod.mod +ED/dbgbuild/bin/aone5_mod.mod +ED/dbgbuild/bin/aone_mod.mod +ED/dbgbuild/bin/aonev_mod.mod +ED/dbgbuild/bin/apply_forestry_mod.mod +ED/dbgbuild/bin/array2xcol_mod.mod +ED/dbgbuild/bin/array2ycol_mod.mod +ED/dbgbuild/bin/array2zcol_mod.mod +ED/dbgbuild/bin/assign_prescribed_phen_mod.mod +ED/dbgbuild/bin/atimb_mod.mod +ED/dbgbuild/bin/atob_log_mod.mod +ED/dbgbuild/bin/atob_mod.mod +ED/dbgbuild/bin/avg_ed_daily_output_pool_mod.mod +ED/dbgbuild/bin/azero2_mod.mod +ED/dbgbuild/bin/azero3_mod.mod +ED/dbgbuild/bin/azero4_mod.mod +ED/dbgbuild/bin/azero5_mod.mod +ED/dbgbuild/bin/azero_mod.mod +ED/dbgbuild/bin/azerov_mod.mod +ED/dbgbuild/bin/banbks_mod.mod +ED/dbgbuild/bin/bandec_mod.mod +ED/dbgbuild/bin/bdf2_solver_mod.mod +ED/dbgbuild/bin/c34constants.mod +ED/dbgbuild/bin/calc_flow_routing_mod.mod +ED/dbgbuild/bin/calchydrosubsurface_mod.mod +ED/dbgbuild/bin/calchydrosurface_mod.mod +ED/dbgbuild/bin/calc_met_lapse_mod.mod +ED/dbgbuild/bin/calcwatertable_mod.mod +ED/dbgbuild/bin/canopy_air_coms.mod +ED/dbgbuild/bin/canopy_derivs_two_mod.mod +ED/dbgbuild/bin/canopy_layer_coms.mod +ED/dbgbuild/bin/canopy_photosynthesis_mod.mod +ED/dbgbuild/bin/canopy_radiation_coms.mod +ED/dbgbuild/bin/canopy_struct_dynamics.mod +ED/dbgbuild/bin/cbrt8_mod.mod +ED/dbgbuild/bin/cbrt_mod.mod +ED/dbgbuild/bin/cdf2normal_mod.mod +ED/dbgbuild/bin/cdf_mod.mod +ED/dbgbuild/bin/char_strip_var_mod.mod +ED/dbgbuild/bin/check_real_mod.mod +ED/dbgbuild/bin/compute_budget_mod.mod +ED/dbgbuild/bin/compute_c_and_n_storage_mod.mod +ED/dbgbuild/bin/compute_co2_storage_mod.mod +ED/dbgbuild/bin/compute_energy_storage_mod.mod +ED/dbgbuild/bin/compute_netrad_mod.mod +ED/dbgbuild/bin/compute_water_storage_mod.mod +ED/dbgbuild/bin/consts_coms.mod +ED/dbgbuild/bin/copy_bdf2_prev_mod.mod +ED/dbgbuild/bin/copy_fb_patch_mod.mod +ED/dbgbuild/bin/copy_initp2prev_mod.mod +ED/dbgbuild/bin/copy_met_2_rk4site_mod.mod +ED/dbgbuild/bin/copy_nl_mod.mod +ED/dbgbuild/bin/copy_patch_init_carbon_mod.mod +ED/dbgbuild/bin/copy_patch_init_mod.mod +ED/dbgbuild/bin/copy_path_from_grid_1_mod.mod +ED/dbgbuild/bin/copy_prev2patch_mod.mod +ED/dbgbuild/bin/copy_rk4_patch_mod.mod +ED/dbgbuild/bin/count_pft_xml_config_mod.mod +ED/dbgbuild/bin/cputime_mod.mod +ED/dbgbuild/bin/create_ed10_ed20_fname_mod.mod +ED/dbgbuild/bin/cumsum_mod.mod +ED/dbgbuild/bin/cvmgm_mod.mod +ED/dbgbuild/bin/cvmgn_mod.mod +ED/dbgbuild/bin/cvmgp_mod.mod +ED/dbgbuild/bin/cvmgz_mod.mod +ED/dbgbuild/bin/date_2_seconds_mod.mod +ED/dbgbuild/bin/date_abs_secs2_mod.mod +ED/dbgbuild/bin/date_add_to_mod.mod +ED/dbgbuild/bin/date_secs_ymdt_mod.mod +ED/dbgbuild/bin/date_unmake_big_mod.mod +ED/dbgbuild/bin/daylength_mod.mod +ED/dbgbuild/bin/dcvmgm_mod.mod +ED/dbgbuild/bin/dcvmgp_mod.mod +ED/dbgbuild/bin/dcw_swap16_mod.mod +ED/dbgbuild/bin/dcw_swap32_mod.mod +ED/dbgbuild/bin/dcw_swap64_mod.mod +ED/dbgbuild/bin/ddens_dt_effect_mod.mod +ED/dbgbuild/bin/deblank_mod.mod +ED/dbgbuild/bin/decomp_coms.mod +ED/dbgbuild/bin/detab_mod.mod +ED/dbgbuild/bin/detailed_coms.mod +ED/dbgbuild/bin/diagon_mod.mod +ED/dbgbuild/bin/dist_gc_mod.mod +ED/dbgbuild/bin/disturbance_utils.mod +ED/dbgbuild/bin/disturb_coms.mod +ED/dbgbuild/bin/dmax2_mod.mod +ED/dbgbuild/bin/dmin2_mod.mod +ED/dbgbuild/bin/dssum_mod.mod +ED/dbgbuild/bin/dump_radinfo_mod.mod +ED/dbgbuild/bin/ed1_fileinfo_mod.mod +ED/dbgbuild/bin/ed_1st_master_mod.mod +ED/dbgbuild/bin/ed_1st_node_mod.mod +ED/dbgbuild/bin/ed21_fileinfo_mod.mod +ED/dbgbuild/bin/ed_datp_datq_mod.mod +ED/dbgbuild/bin/ed_datp_datsoil_mod.mod +ED/dbgbuild/bin/ed_driver_mod.mod +ED/dbgbuild/bin/ed_filelist_mod.mod +ED/dbgbuild/bin/ed_gridset_mod.mod +ED/dbgbuild/bin/ed_init_atm_mod.mod +ED/dbgbuild/bin/ed_ll_xy_mod.mod +ED/dbgbuild/bin/ed_load_work_from_history_mod.mod +ED/dbgbuild/bin/ed_masterput_met_header_mod.mod +ED/dbgbuild/bin/ed_masterput_nl_mod.mod +ED/dbgbuild/bin/ed_masterput_poly_dims_mod.mod +ED/dbgbuild/bin/ed_masterput_processid_mod.mod +ED/dbgbuild/bin/ed_masterput_worklist_info_mod.mod +ED/dbgbuild/bin/ed_max_dims.mod +ED/dbgbuild/bin/ed_mem_alloc_mod.mod +ED/dbgbuild/bin/ed_mem_grid_dim_defs.mod +ED/dbgbuild/bin/ed_misc_coms.mod +ED/dbgbuild/bin/ed_model_mod.mod +ED/dbgbuild/bin/ed_newgrid_mod.mod +ED/dbgbuild/bin/ed_node_coms.mod +ED/dbgbuild/bin/ed_node_decomp_mod.mod +ED/dbgbuild/bin/ed_nodeget_met_header_mod.mod +ED/dbgbuild/bin/ed_nodeget_nl_mod.mod +ED/dbgbuild/bin/ed_nodeget_poly_dims_mod.mod +ED/dbgbuild/bin/ed_nodeget_processid_mod.mod +ED/dbgbuild/bin/ed_nodeget_worklist_info_mod.mod +ED/dbgbuild/bin/ed_opspec_grid_mod.mod +ED/dbgbuild/bin/ed_opspec_misc_mod.mod +ED/dbgbuild/bin/ed_opspec_par_mod.mod +ED/dbgbuild/bin/ed_opspec_times_mod.mod +ED/dbgbuild/bin/ed_output_mod.mod +ED/dbgbuild/bin/ed_para_coms.mod +ED/dbgbuild/bin/ed_parvec_work_mod.mod +ED/dbgbuild/bin/ed_polarst_mod.mod +ED/dbgbuild/bin/ed_state_vars.mod +ED/dbgbuild/bin/ed_therm_lib.mod +ED/dbgbuild/bin/ed_var_tables.mod +ED/dbgbuild/bin/ed_work_vars.mod +ED/dbgbuild/bin/ed_xy_ll_mod.mod +ED/dbgbuild/bin/ed_zen_mod.mod +ED/dbgbuild/bin/eifun8_mod.mod +ED/dbgbuild/bin/elgs_mod.mod +ED/dbgbuild/bin/ename_coms.mod +ED/dbgbuild/bin/endian_mod.mod +ED/dbgbuild/bin/errorfun_mod.mod +ED/dbgbuild/bin/euler_integ_mod.mod +ED/dbgbuild/bin/euler_timestep_mod.mod +ED/dbgbuild/bin/event_fertilize_mod.mod +ED/dbgbuild/bin/event_fire_mod.mod +ED/dbgbuild/bin/event_harvest_mod.mod +ED/dbgbuild/bin/event_irrigate_mod.mod +ED/dbgbuild/bin/event_planting_mod.mod +ED/dbgbuild/bin/event_till_mod.mod +ED/dbgbuild/bin/expected_mod.mod +ED/dbgbuild/bin/expmsq_mod.mod +ED/dbgbuild/bin/exterminate_patches_except_mod.mod +ED/dbgbuild/bin/fail_whale_mod.mod +ED/dbgbuild/bin/farq_leuning.mod +ED/dbgbuild/bin/fatal_error_mod.mod +ED/dbgbuild/bin/fb_dy_step_trunc_mod.mod +ED/dbgbuild/bin/fb_sanity_check_mod.mod +ED/dbgbuild/bin/fill_history_grid_mod.mod +ED/dbgbuild/bin/fill_history_patch_mod.mod +ED/dbgbuild/bin/fill_history_polygon_mod.mod +ED/dbgbuild/bin/fill_history_site_mod.mod +ED/dbgbuild/bin/fillvar_l_mod.mod +ED/dbgbuild/bin/find_closing_comment_mod.mod +ED/dbgbuild/bin/find_frqsum_mod.mod +ED/dbgbuild/bin/findln_mod.mod +ED/dbgbuild/bin/find_rank_mod.mod +ED/dbgbuild/bin/fire_frequency_mod.mod +ED/dbgbuild/bin/first_phenology_mod.mod +ED/dbgbuild/bin/flag_stable_cohorts_mod.mod +ED/dbgbuild/bin/fuse_fiss_utils.mod +ED/dbgbuild/bin/fusion_fission_coms.mod +ED/dbgbuild/bin/getconfigint_mod.mod +ED/dbgbuild/bin/getconfigreal_mod.mod +ED/dbgbuild/bin/getconfigstring_mod.mod +ED/dbgbuild/bin/get_errmax_mod.mod +ED/dbgbuild/bin/get_file_indices_mod.mod +ED/dbgbuild/bin/get_grid_mod.mod +ED/dbgbuild/bin/geth5dims_mod.mod +ED/dbgbuild/bin/getll_mod.mod +ED/dbgbuild/bin/get_work_mod.mod +ED/dbgbuild/bin/get_yscal_mod.mod +ED/dbgbuild/bin/grid_coms.mod +ED/dbgbuild/bin/growth_balive.mod +ED/dbgbuild/bin/h5_output_mod.mod +ED/dbgbuild/bin/harv_immat_patches_mod.mod +ED/dbgbuild/bin/harv_mat_patches_mod.mod +ED/dbgbuild/bin/hdf5_coms.mod +ED/dbgbuild/bin/hdf5_utils.mod +ED/dbgbuild/bin/hdf_getslab_d_mod.mod +ED/dbgbuild/bin/hdf_getslab_i_mod.mod +ED/dbgbuild/bin/hdf_getslab_r_mod.mod +ED/dbgbuild/bin/heav_mod.mod +ED/dbgbuild/bin/het_resp_weight_mod.mod +ED/dbgbuild/bin/heun_integ_mod.mod +ED/dbgbuild/bin/heun_stepper_mod.mod +ED/dbgbuild/bin/heun_timestep_mod.mod +ED/dbgbuild/bin/how_to_read_a_file_mod.mod +ED/dbgbuild/bin/hybrid_integ_mod.mod +ED/dbgbuild/bin/hybrid_timestep_mod.mod +ED/dbgbuild/bin/hydrology_coms.mod +ED/dbgbuild/bin/hydrology_constants.mod +ED/dbgbuild/bin/ibias_mod.mod +ED/dbgbuild/bin/ibindec_mod.mod +ED/dbgbuild/bin/ifirstchar_mod.mod +ED/dbgbuild/bin/inc_fwd_patch_mod.mod +ED/dbgbuild/bin/inc_rk4_patch_mod.mod +ED/dbgbuild/bin/init_can_air_params_mod.mod +ED/dbgbuild/bin/init_can_lyr_params_mod.mod +ED/dbgbuild/bin/init_can_rad_params_mod.mod +ED/dbgbuild/bin/init_cohorts_by_layers_mod.mod +ED/dbgbuild/bin/init_decomp_params_mod.mod +ED/dbgbuild/bin/init_disturb_params_mod.mod +ED/dbgbuild/bin/init_ed_cohort_vars_mod.mod +ED/dbgbuild/bin/init_ed_misc_coms_mod.mod +ED/dbgbuild/bin/init_ed_patch_vars_mod.mod +ED/dbgbuild/bin/init_ed_poly_vars_mod.mod +ED/dbgbuild/bin/init_ed_site_vars_mod.mod +ED/dbgbuild/bin/init_ff_coms_mod.mod +ED/dbgbuild/bin/init_full_history_restart_mod.mod +ED/dbgbuild/bin/init_hydro_coms_mod.mod +ED/dbgbuild/bin/inithydrology_mod.mod +ED/dbgbuild/bin/inithydrosubsurface_mod.mod +ED/dbgbuild/bin/initialize_rk4patches_mod.mod +ED/dbgbuild/bin/init_lapse_params_mod.mod +ED/dbgbuild/bin/init_met_drivers_mod.mod +ED/dbgbuild/bin/init_met_params_mod.mod +ED/dbgbuild/bin/init_nbg_cohorts_mod.mod +ED/dbgbuild/bin/init_pft_alloc_params_mod.mod +ED/dbgbuild/bin/init_pft_derived_params_mod.mod +ED/dbgbuild/bin/init_pft_leaf_params_mod.mod +ED/dbgbuild/bin/init_pft_mort_params_mod.mod +ED/dbgbuild/bin/init_pft_nitro_params_mod.mod +ED/dbgbuild/bin/init_pft_photo_params_mod.mod +ED/dbgbuild/bin/init_pft_repro_params_mod.mod +ED/dbgbuild/bin/init_pft_resp_params_mod.mod +ED/dbgbuild/bin/init_phen_coms_mod.mod +ED/dbgbuild/bin/init_physiology_params_mod.mod +ED/dbgbuild/bin/init_rk4_params_mod.mod +ED/dbgbuild/bin/init_soil_coms_mod.mod +ED/dbgbuild/bin/integrate_ed_daily_output_flux_mod.mod +ED/dbgbuild/bin/integrate_ed_daily_output_state_mod.mod +ED/dbgbuild/bin/integrate_ed_monthly_output_vars_mod.mod +ED/dbgbuild/bin/integrate_patch_euler_mod.mod +ED/dbgbuild/bin/integrate_patch_heun_mod.mod +ED/dbgbuild/bin/int_met_avg_mod.mod +ED/dbgbuild/bin/inventory_mat_forests_mod.mod +ED/dbgbuild/bin/iprim_mod.mod +ED/dbgbuild/bin/iran_recsize_mod.mod +ED/dbgbuild/bin/is_finite8_mod.mod +ED/dbgbuild/bin/is_finite_mod.mod +ED/dbgbuild/bin/isleap_mod.mod +ED/dbgbuild/bin/ismax_mod.mod +ED/dbgbuild/bin/ismin_mod.mod +ED/dbgbuild/bin/is_resolvable_mod.mod +ED/dbgbuild/bin/ivalugp_mod.mod +ED/dbgbuild/bin/izero2_mod.mod +ED/dbgbuild/bin/izero3_mod.mod +ED/dbgbuild/bin/izero4_mod.mod +ED/dbgbuild/bin/izero5_mod.mod +ED/dbgbuild/bin/izero_mod.mod +ED/dbgbuild/bin/izerov_mod.mod +ED/dbgbuild/bin/julday1000_mod.mod +ED/dbgbuild/bin/julday_mod.mod +ED/dbgbuild/bin/landuse_init_mod.mod +ED/dbgbuild/bin/large_error_mod.mod +ED/dbgbuild/bin/lastchar_mod.mod +ED/dbgbuild/bin/lastmonthdate_mod.mod +ED/dbgbuild/bin/lastslash_mod.mod +ED/dbgbuild/bin/leaf_database_mod.mod +ED/dbgbuild/bin/leaf_derivs_mod.mod +ED/dbgbuild/bin/leaftw_derivs_mod.mod +ED/dbgbuild/bin/libxml2f90__closeall_mod.mod +ED/dbgbuild/bin/libxml2f90__closefile_mod.mod +ED/dbgbuild/bin/libxml2f90_error_getline_mod.mod +ED/dbgbuild/bin/libxml2f90__existid_mod.mod +ED/dbgbuild/bin/libxml2f90_existid_mod.mod +ED/dbgbuild/bin/libxml2f90__existpid_mod.mod +ED/dbgbuild/bin/libxml2f90__findinchara_mod.mod +ED/dbgbuild/bin/libxml2f90__flush_mod.mod +ED/dbgbuild/bin/libxml2f90__get_fileunit_mod.mod +ED/dbgbuild/bin/libxml2f90_getline_mod.mod +ED/dbgbuild/bin/libxml2f90_getsafec8_mod.mod +ED/dbgbuild/bin/libxml2f90_getsafei4_mod.mod +ED/dbgbuild/bin/libxml2f90_getsafel4_mod.mod +ED/dbgbuild/bin/libxml2f90_getsafer8_mod.mod +ED/dbgbuild/bin/libxml2f90__getunit_mod.mod +ED/dbgbuild/bin/libxml2f90_interface_module.mod +ED/dbgbuild/bin/libxml2f90__ll_addid_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_addid_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_add_list_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_add_list_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_addpid_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_addpid_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_addpureid_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_closetag_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_closetag_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_down_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_edit_id_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_edit_id_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_edit_pid_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_edit_pid_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_exist_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getc8__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getc8_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_getc8_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getch_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_getch_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getch_scal_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_geti4__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_geti4_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_geti4_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getl4__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getl4_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_getl4_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpc8__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpc8_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpch_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpi4__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpi4_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpl4__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpl4_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpr8__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpr8_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpsize_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpstring__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getpstring_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getr8__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getr8_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_getr8_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getsize_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_getsize_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getstring__mod.mod +ED/dbgbuild/bin/libxml2f90__ll_getstring_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_getstring_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_initlist_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_inittag_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_opentag_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_opentag_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_report_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_report_rec_mod.mod +ED/dbgbuild/bin/libxml2f90_ll_report_rec_wrap_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_selectlist_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_selecttag_mod.mod +ED/dbgbuild/bin/libxml2f90__ll_up_mod.mod +ED/dbgbuild/bin/libxml2f90_module.mod +ED/dbgbuild/bin/libxml2f90__openfile_mod.mod +ED/dbgbuild/bin/libxml2f90_parse_file_mod.mod +ED/dbgbuild/bin/libxml2f90_parse_find_char_mod.mod +ED/dbgbuild/bin/libxml2f90__readin_file_mod.mod +ED/dbgbuild/bin/libxml2f90_readin_file_mod.mod +ED/dbgbuild/bin/libxml2f90__readin_nfil_mod.mod +ED/dbgbuild/bin/libxml2f90__set_casesensitive_mod.mod +ED/dbgbuild/bin/libxml2f90__set_default_ll_id_mod.mod +ED/dbgbuild/bin/libxml2f90__setformat_mod.mod +ED/dbgbuild/bin/libxml2f90__set_paw_mod.mod +ED/dbgbuild/bin/libxml2f90__set_rmcomma_mod.mod +ED/dbgbuild/bin/libxml2f90__set_rmquotes_mod.mod +ED/dbgbuild/bin/libxml2f90__settransform_exm_mod.mod +ED/dbgbuild/bin/libxml2f90__setwrite_exm_mod.mod +ED/dbgbuild/bin/libxml2f90_strings_module.mod +ED/dbgbuild/bin/libxml2f90_tostringa_mod.mod +ED/dbgbuild/bin/libxml2f90_tostring_mod.mod +ED/dbgbuild/bin/libxml2f90_transform_paw_mod.mod +ED/dbgbuild/bin/lisys_solver8_mod.mod +ED/dbgbuild/bin/lisys_solver_mod.mod +ED/dbgbuild/bin/ll_module.mod +ED/dbgbuild/bin/load_ecosystem_state_mod.mod +ED/dbgbuild/bin/load_ed_ecosystem_params_mod.mod +ED/dbgbuild/bin/lubksb_dble_mod.mod +ED/dbgbuild/bin/ludcmp_dble_mod.mod +ED/dbgbuild/bin/lw_multiple_scatter_mod.mod +ED/dbgbuild/bin/lw_twostream_mod.mod +ED/dbgbuild/bin/makefnam_mod.mod +ED/dbgbuild/bin/match_poly_grid_mod.mod +ED/dbgbuild/bin/mat_forest_harv_rates_mod.mod +ED/dbgbuild/bin/mean_daysecz_mod.mod +ED/dbgbuild/bin/mem_polygons.mod +ED/dbgbuild/bin/met_driver_coms.mod +ED/dbgbuild/bin/met_sanity_check_mod.mod +ED/dbgbuild/bin/migs_mod.mod +ED/dbgbuild/bin/mk_2_buff_mod.mod +ED/dbgbuild/bin/mk_2p_buff_mod.mod +ED/dbgbuild/bin/mk_3_buff_mod.mod +ED/dbgbuild/bin/mk_4_buff_mod.mod +ED/dbgbuild/bin/mortality.mod +ED/dbgbuild/bin/mprove_mod.mod +ED/dbgbuild/bin/near_bare_ground_big_leaf_init_mod.mod +ED/dbgbuild/bin/near_bare_ground_init_mod.mod +ED/dbgbuild/bin/new_patch_sfc_props_mod.mod +ED/dbgbuild/bin/normalize_averaged_vars_mod.mod +ED/dbgbuild/bin/normalize_ed_dailynpp_vars_mod.mod +ED/dbgbuild/bin/normalize_ed_daily_output_vars_mod.mod +ED/dbgbuild/bin/normalize_ed_daily_vars_mod.mod +ED/dbgbuild/bin/normalize_ed_monthly_output_vars_mod.mod +ED/dbgbuild/bin/norm_harv_patch_mod.mod +ED/dbgbuild/bin/num_days_mod.mod +ED/dbgbuild/bin/odeint_mod.mod +ED/dbgbuild/bin/opspec_fatal_mod.mod +ED/dbgbuild/bin/optimiz_coms.mod +ED/dbgbuild/bin/overwrite_with_xml_config_mod.mod +ED/dbgbuild/bin/parsefnam_mod.mod +ED/dbgbuild/bin/parse_mod.mod +ED/dbgbuild/bin/pft_coms.mod +ED/dbgbuild/bin/pheninit_balive_bstorage_mod.mod +ED/dbgbuild/bin/phenology_aux.mod +ED/dbgbuild/bin/phenology_coms.mod +ED/dbgbuild/bin/phenology_driver_eq_0_mod.mod +ED/dbgbuild/bin/phenology_driver_mod.mod +ED/dbgbuild/bin/phenology_startup.mod +ED/dbgbuild/bin/phenology_thresholds_mod.mod +ED/dbgbuild/bin/physiology_coms.mod +ED/dbgbuild/bin/plant_structural_allocation_mod.mod +ED/dbgbuild/bin/prescribed_event_mod.mod +ED/dbgbuild/bin/prescribed_leaf_state_mod.mod +ED/dbgbuild/bin/print_c_and_n_budgets_mod.mod +ED/dbgbuild/bin/print_csiteipa_mod.mod +ED/dbgbuild/bin/print_errmax_mod.mod +ED/dbgbuild/bin/print_fields_mod.mod +ED/dbgbuild/bin/print_photo_details_mod.mod +ED/dbgbuild/bin/print_rk4patch_mod.mod +ED/dbgbuild/bin/print_rk4_state_mod.mod +ED/dbgbuild/bin/print_soil_info_mod.mod +ED/dbgbuild/bin/putconfigint_mod.mod +ED/dbgbuild/bin/putconfigreal8_mod.mod +ED/dbgbuild/bin/putconfigreal_mod.mod +ED/dbgbuild/bin/putconfigstring_mod.mod +ED/dbgbuild/bin/radiate_driver_mod.mod +ED/dbgbuild/bin/rams_f_open_mod.mod +ED/dbgbuild/bin/rank_down_mod.mod +ED/dbgbuild/bin/rank_up_mod.mod +ED/dbgbuild/bin/read_ed10_ed20_history_file_mod.mod +ED/dbgbuild/bin/read_ed21_history_file_mod.mod +ED/dbgbuild/bin/read_ed21_history_unstruct_mod.mod +ED/dbgbuild/bin/read_ed_xml_config_mod.mod +ED/dbgbuild/bin/read_events_xml_mod.mod +ED/dbgbuild/bin/read_met_driver_head_mod.mod +ED/dbgbuild/bin/read_met_drivers_init_mod.mod +ED/dbgbuild/bin/read_met_drivers_mod.mod +ED/dbgbuild/bin/read_nl_mod.mod +ED/dbgbuild/bin/read_ol_file_mod.mod +ED/dbgbuild/bin/read_plantation_fractions_mod.mod +ED/dbgbuild/bin/read_site_file_mod.mod +ED/dbgbuild/bin/read_soil_depth_mod.mod +ED/dbgbuild/bin/read_soil_moist_temp_mod.mod +ED/dbgbuild/bin/rearrange_mod.mod +ED/dbgbuild/bin/reproduction_eq_0_mod.mod +ED/dbgbuild/bin/reproduction_mod.mod +ED/dbgbuild/bin/reset_averaged_vars_mod.mod +ED/dbgbuild/bin/resp_f_decomp_mod.mod +ED/dbgbuild/bin/resp_rh_mod.mod +ED/dbgbuild/bin/rk4_coms.mod +ED/dbgbuild/bin/rk4_driver.mod +ED/dbgbuild/bin/rk4_stepper.mod +ED/dbgbuild/bin/root_resp_norm_mod.mod +ED/dbgbuild/bin/scale_ed_radiation_mod.mod +ED/dbgbuild/bin/seed_dispersal_mod.mod +ED/dbgbuild/bin/selective_gaussian_2body_mod.mod +ED/dbgbuild/bin/setlapseparms_mod.mod +ED/dbgbuild/bin/set_polygon_coordinates_mod.mod +ED/dbgbuild/bin/set_site_defprops_mod.mod +ED/dbgbuild/bin/sfcdata_ed_mod.mod +ED/dbgbuild/bin/sfcrad_ed_mod.mod +ED/dbgbuild/bin/short2diff_sib_mod.mod +ED/dbgbuild/bin/short_bdown_weissnorman_mod.mod +ED/dbgbuild/bin/sngloff_mod.mod +ED/dbgbuild/bin/soil_coms.mod +ED/dbgbuild/bin/soil_depth_fill_mod.mod +ED/dbgbuild/bin/soil_respiration_mod.mod +ED/dbgbuild/bin/solar_radiation_breakdown_mod.mod +ED/dbgbuild/bin/sort3_mod.mod +ED/dbgbuild/bin/sort_down_mod.mod +ED/dbgbuild/bin/sort_up_mod.mod +ED/dbgbuild/bin/spatial_averages_mod.mod +ED/dbgbuild/bin/ssum_mod.mod +ED/dbgbuild/bin/structural_growth_eq_0_mod.mod +ED/dbgbuild/bin/structural_growth_mod.mod +ED/dbgbuild/bin/sum_plant_cfluxes_mod.mod +ED/dbgbuild/bin/sw_multiple_scatter_mod.mod +ED/dbgbuild/bin/sw_twostream_clump_mod.mod +ED/dbgbuild/bin/test_mod.mod +ED/dbgbuild/bin/therm_lib8.mod +ED/dbgbuild/bin/therm_lib.mod +ED/dbgbuild/bin/timing_mod.mod +ED/dbgbuild/bin/tokenize1_mod.mod +ED/dbgbuild/bin/tolower_mod.mod +ED/dbgbuild/bin/transfer_ol_month_mod.mod +ED/dbgbuild/bin/trid2_mod.mod +ED/dbgbuild/bin/trid_mod.mod +ED/dbgbuild/bin/ugetarg_mod.mod +ED/dbgbuild/bin/unarrange_mod.mod +ED/dbgbuild/bin/update_budget_mod.mod +ED/dbgbuild/bin/update_c_and_n_pools_mod.mod +ED/dbgbuild/bin/update_derived_cohort_props_mod.mod +ED/dbgbuild/bin/update_derived_props_mod.mod +ED/dbgbuild/bin/update_diagnostic_vars_mod.mod +ED/dbgbuild/bin/update_ed_yearly_vars_mod.mod +ED/dbgbuild/bin/updatehydroparms_mod.mod +ED/dbgbuild/bin/update_met_drivers_mod.mod +ED/dbgbuild/bin/update_model_time_dm_mod.mod +ED/dbgbuild/bin/update_mod.mod +ED/dbgbuild/bin/update_patch_derived_props_mod.mod +ED/dbgbuild/bin/update_patch_thermo_props_mod.mod +ED/dbgbuild/bin/update_phenology_eq_0_mod.mod +ED/dbgbuild/bin/update_phenology_mod.mod +ED/dbgbuild/bin/update_polygon_derived_props_mod.mod +ED/dbgbuild/bin/update_rad_avg_mod.mod +ED/dbgbuild/bin/update_site_derived_props_mod.mod +ED/dbgbuild/bin/update_thermal_sums_mod.mod +ED/dbgbuild/bin/update_turnover_mod.mod +ED/dbgbuild/bin/update_vital_rates_mod.mod +ED/dbgbuild/bin/updatewatertableadd_mod.mod +ED/dbgbuild/bin/updatewatertablebaseflow_mod.mod +ED/dbgbuild/bin/updatewatertablesubtract_mod.mod +ED/dbgbuild/bin/update_workload_mod.mod +ED/dbgbuild/bin/valugp_mod.mod +ED/dbgbuild/bin/vegetation_dynamics_eq_0_mod.mod +ED/dbgbuild/bin/vegetation_dynamics_mod.mod +ED/dbgbuild/bin/walltime_mod.mod +ED/dbgbuild/bin/warning_mod.mod +ED/dbgbuild/bin/write_ed_xml_config_mod.mod +ED/dbgbuild/bin/writehydro_mod.mod +ED/dbgbuild/bin/xcol2array_mod.mod +ED/dbgbuild/bin/ycol2array_mod.mod +ED/dbgbuild/bin/yesterday_mod.mod +ED/dbgbuild/bin/zcol2array_mod.mod +ED/dbgbuild/bin/zero_ed_daily_output_vars_mod.mod +ED/dbgbuild/bin/zero_ed_daily_vars_mod.mod +ED/dbgbuild/bin/zero_ed_monthly_output_vars_mod.mod +ED/dbgbuild/bin/zero_ed_yearly_vars_mod.mod +Ramspost/build/bin/rout_coms.mod +BRAMS/gnubuild +BRAMS/i11build diff --git a/BRAMS/Template/RAMSIN b/BRAMS/Template/RAMSIN index 2334ac12a..772d01180 100644 --- a/BRAMS/Template/RAMSIN +++ b/BRAMS/Template/RAMSIN @@ -889,7 +889,7 @@ $CUPARM_OPTIONS ! PS3: If NCLOUDS >= 3, then the middle ones will necessarily use Grell's ! ! parameterization. ! !---------------------------------------------------------------------------------------! - NCLOUDS = 2, + NCLOUDS = 4, !---------------------------------------------------------------------------------------! @@ -917,7 +917,7 @@ $CUPARM_OPTIONS ! CONFRQ: how often should the cumulus parametrisation be updated? ! ! CPTIME: when I should start computing the cumulus parametrisation. ! !---------------------------------------------------------------------------------------! - CONFRQ = 1200., + CONFRQ = 720., CPTIME = 0., !---------------------------------------------------------------------------------------! @@ -945,8 +945,8 @@ $CUPARM_OPTIONS ! (grell_coms.f90). Default min_down_radius is 900. ! ! DEPTH_MIN - Minimum depth that the cloud must have [m]. ! !---------------------------------------------------------------------------------------! - RADIUS = 12000., 600., ! 4577., 1746., 666., - DEPTH_MIN = 1200., 100., ! 457.7, 174.6, 66.6, + RADIUS = 12000., 4800., 1800., 600., + DEPTH_MIN = 6000., 2400., 900., 200., !---------------------------------------------------------------------------------------! @@ -963,7 +963,7 @@ $CUPARM_OPTIONS ! velocity and sigma-w and assuming normal distribution, so this option works ! ! only when IDIFFK is 1 or 7. ! !---------------------------------------------------------------------------------------! - CAP_MAXS = -25., + CAP_MAXS = -20., !---------------------------------------------------------------------------------------! @@ -971,11 +971,11 @@ $CUPARM_OPTIONS !---------------------------------------------------------------------------------------! ! The following variables are scalars. ! !---------------------------------------------------------------------------------------! - CLD2PREC = 0.001, ! Ratio of conversion of condensates to precipitation. [ ---] + CLD2PREC = 0.002, ! Ratio of conversion of condensates to precipitation. [ ---] ZKBMAX = 4000., ! Maximum AGL height in which updrafts can originate. [ m] ZCUTDOWN = 3000., ! Maximum AGL height in which downdrafts can originate. [ m] Z_DETR = 1250., ! Top of the downdraft detrainment layer [ m] - MAX_HEAT = 600., ! Maximum heating rate allowed for feedback [ K/day] + MAX_HEAT = 250., ! Maximum heating rate allowed for feedback [ K/day] !---------------------------------------------------------------------------------------! @@ -1053,6 +1053,15 @@ $MODEL_OPTIONS + !---------------------------------------------------------------------------------------! + ! IADVEC -- 1 - Original advection scheme ! + ! 2 - Monotic advection scheme, as in Freitas et al. (2001, in press JAMES). ! + !---------------------------------------------------------------------------------------! + IADVEC = 2, + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! ! IEXEV -- Exner function tendency. ! ! 1 -- original BRAMS. This ignores advection, compression and heating. Not ! @@ -1331,7 +1340,7 @@ $MODEL_OPTIONS ! or 1, only the first value will be considered, and if ICO2=2, then ! ! provide one value per level. Unit here is µmol/mol. ! !------------------------------------------------------------------------------------! - ICO2 = 0, + ICO2 = 1, CO2CON = 380., !------------------------------------------------------------------------------------! @@ -1768,7 +1777,7 @@ $MODEL_OPTIONS ! is set to 5, CPARM represents the concentration of CCN. Otherwise, the ! ! value is ignored if the IXXXX variable is set to 5. ! !------------------------------------------------------------------------------------! - CPARM = .3e9, ! cloud droplets, or less frequently, CCN + CPARM = 1.3e9, ! cloud droplets, or less frequently, CCN RPARM = 1e-3, ! rain drops PPARM = 0., ! pristine ice (ignored as IPRIS must be 5) SPARM = 1e-3, ! snow @@ -1992,7 +2001,7 @@ $ED2_INFO !---------------------------------------------------------------------------------------! VEG_DATABASE = '/n/Moorcroft_Lab/Lab/data/ed2_data/oge2OLD/OGE2_', SOIL_DATABASE = '/n/Moorcroft_Lab/Lab/data/ed2_data/faoOLD/FAO_', - LU_DATABASE = '/n/Moorcroft_Lab/Lab/data/ed2_data/land_use/glu/glu-', + LU_DATABASE = '/n/Moorcroft_Lab/Lab/data/ed2_data/land_use/glu-3.3.1+sa1/half/glu-3.3.1+sa1-', PLANTATION_FILE = '', LU_RESCALE_FILE = '/n/Moorcroft_Lab/Lab/data/ed2_data/21restart/rescale/SA1relative.lu.area-22km-2038.txt', THSUMS_DATABASE = '/n/Moorcroft_Lab/Lab/data/ed2_data/ed_inputs/', @@ -2045,12 +2054,31 @@ $ED2_INFO + + !---------------------------------------------------------------------------------------! + ! IBIGLEAF -- Do you want to run ED as a 'big leaf' model? ! + ! 0. No, use the standard size- and age-structure (Moorcroft et al. 2001) ! + ! This is the recommended method for most applications. ! + ! 1. 'big leaf' ED: this will have no horizontal or vertical hetero- ! + ! geneities; 1 patch per PFT and 1 cohort per patch; no vertical ! + ! growth, recruits will 'appear' instantaneously at maximum height. ! + ! ! + ! N.B. if you set IBIGLEAF to 1, you MUST turn off the crown model (CROWN_MOD = 0) ! + !---------------------------------------------------------------------------------------! + IBIGLEAF = 0, + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! ! INTEGRATION_SCHEME -- The biophysics integration scheme. ! ! 0. Euler step. The fastest, but it doesn't estimate ! ! errors. ! ! 1. Fourth-order Runge-Kutta method. ED-2.1 default method ! ! 2. Heun's method (a second-order Runge-Kutta). ! + ! 3. Hybrid Stepping (BDF2 implicit step for the canopy air and ! + ! leaf temp, forward Euler for else, under development). ! !---------------------------------------------------------------------------------------! INTEGRATION_SCHEME = 1, !---------------------------------------------------------------------------------------! @@ -2081,7 +2109,7 @@ $ED2_INFO ! 2. Similar to 1, but branches are treated as separate pools in the ! ! biophysics (thus doubling the number of prognostic variables). ! !---------------------------------------------------------------------------------------! - IBRANCH_THERMO = 0, + IBRANCH_THERMO = 1, !---------------------------------------------------------------------------------------! @@ -2129,7 +2157,7 @@ $ED2_INFO ! a few genuses in Costa Rica. References: ! ! Cole and Ewel (2006), and Calvo Alvarado et al. (2008). ! !---------------------------------------------------------------------------------------! - IALLOM = 2, + IALLOM = 1, !---------------------------------------------------------------------------------------! @@ -2193,6 +2221,10 @@ $ED2_INFO ! to the same polygon, even if they are in different sites. They ! ! can't go outside their original polygon, though. This is the ! ! same as option 1 if there is only one site per polygon. ! + ! 3. Similar to 2, but recruits will only be formed if their phenology ! + ! status would be "leaves fully flushed". This only matters for ! + ! drought deciduous plants. This option is for testing purposes ! + ! only, think 50 times before using it... ! !---------------------------------------------------------------------------------------! REPRO_SCHEME = 2, !---------------------------------------------------------------------------------------! @@ -2259,9 +2291,9 @@ $ED2_INFO LTRANS_NIR = 0.270, LREFLECT_VIS = 0.100, LREFLECT_NIR = 0.540, - ORIENT_TREE = 0.150, - ORIENT_GRASS = -0.050, - CLUMP_TREE = 1.000, + ORIENT_TREE = 0.100, + ORIENT_GRASS = -0.100, + CLUMP_TREE = 0.800, CLUMP_GRASS = 1.000, !---------------------------------------------------------------------------------------! @@ -2297,7 +2329,7 @@ $ED2_INFO ! depth, H it the crown height and psi_fc and psi_wp are the ! ! matric potentials at wilting point and field capacity. This is ! !---------------------------------------------------------------------------------------! - H2O_PLANT_LIM = 1, + H2O_PLANT_LIM = 2, !---------------------------------------------------------------------------------------! @@ -2344,22 +2376,22 @@ $ED2_INFO ! Q10_C3 -- Q10 factor for C3 plants (used only if IPHYSIOL is set to 2 or 3). ! ! Q10_C4 -- Q10 factor for C4 plants (used only if IPHYSIOL is set to 2 or 3). ! !---------------------------------------------------------------------------------------! - VMFACT_C3 = 1.25, + VMFACT_C3 = 1.00, VMFACT_C4 = 1.00, MPHOTO_TRC3 = 9.0, MPHOTO_TEC3 = 7.2, - MPHOTO_C4 = 5.0, + MPHOTO_C4 = 5.2, BPHOTO_BLC3 = 10000., BPHOTO_NLC3 = 1000., - BPHOTO_C4 = 8000., - KW_GRASS = 300., - KW_TREE = 300., + BPHOTO_C4 = 10000., + KW_GRASS = 600., + KW_TREE = 450., GAMMA_C3 = 0.015, - GAMMA_C4 = 0.036, - D0_GRASS = 0.015, - D0_TREE = 0.015, + GAMMA_C4 = 0.040, + D0_GRASS = 0.016, + D0_TREE = 0.016, ALPHA_C3 = 0.080, - ALPHA_C4 = 0.053, + ALPHA_C4 = 0.055, KLOWCO2IN = 4000., RRFFACT = 1.000, GROWTHRESP = 0.33333333333, @@ -2382,7 +2414,7 @@ $ED2_INFO ! ing point is by definition -1.5MPa, so make sure that the value ! ! is above -1.5. ! !---------------------------------------------------------------------------------------! - THETACRIT = -1.20, + THETACRIT = -1.15, !---------------------------------------------------------------------------------------! @@ -2421,25 +2453,29 @@ $ED2_INFO !---------------------------------------------------------------------------------------! ! The following parameters adjust the fire disturbance in the model. ! - ! INCLUDE_FIRE -- Which threshold to use for fires. ! - ! 0. No fires; ! - ! 1. (deprecated) Fire will be triggered with enough biomass and ! - ! integrated ground water depth less than a threshold. Based on ! - ! ED-1, the threshold assumes that the soil is 1 m, so deeper ! - ! soils will need to be much drier to allow fires to happen and ! - ! often will never allow fires. ! - ! 2. Fire will be triggered with enough biomass and the total soil ! - ! water at the top 75 cm falls below a threshold. ! - ! SM_FIRE -- This is used only when INCLUDE_FIRE = 2. The sign here matters. ! - ! >= 0. - Minimum relative soil moisture above dry air of the top 75cm ! - ! that will prevent fires to happen. ! - ! < 0. - Minimum mean soil moisture potential in MPa of the top 75 cm ! - ! that will prevent fires to happen. The dry air soil ! - ! potential is defined as -3.1 MPa, so make sure SM_FIRE is ! - ! greater than this value. ! - !---------------------------------------------------------------------------------------! - INCLUDE_FIRE = 2, - SM_FIRE = 0.07, + ! INCLUDE_FIRE -- Which threshold to use for fires. ! + ! 0. No fires; ! + ! 1. (deprecated) Fire will be triggered with enough biomass and ! + ! integrated ground water depth less than a threshold. Based on ! + ! ED-1, the threshold assumes that the soil is 1 m, so deeper ! + ! soils will need to be much drier to allow fires to happen and ! + ! often will never allow fires. ! + ! 2. Fire will be triggered with enough biomass and the total soil ! + ! water at the top 75 cm falls below a threshold. ! + ! FIRE_PARAMETER -- If fire happens, this will control the intensity of the disturbance ! + ! given the amount of fuel (currently the total above-ground ! + ! biomass). ! + ! SM_FIRE -- This is used only when INCLUDE_FIRE = 2. The sign here matters. ! + ! >= 0. - Minimum relative soil moisture above dry air of the top 1m ! + ! that will prevent fires to happen. ! + ! < 0. - Minimum mean soil moisture potential in MPa of the top 1m ! + ! that will prevent fires to happen. The dry air soil ! + ! potential is defined as -3.1 MPa, so make sure SM_FIRE is ! + ! greater than this value. ! + !---------------------------------------------------------------------------------------! + INCLUDE_FIRE = 2, + FIRE_PARAMETER = 0.1, + SM_FIRE = -1.45, !---------------------------------------------------------------------------------------! @@ -2470,7 +2506,7 @@ $ED2_INFO ! 4. Same as 0, but if finds the ground conductance following CLM ! ! technical note (equations 5.98-5.100). ! !---------------------------------------------------------------------------------------! - ICANTURB = 4, + ICANTURB = 2, !---------------------------------------------------------------------------------------! @@ -2518,21 +2554,24 @@ $ED2_INFO !---------------------------------------------------------------------------------------! ! The following variables control the size of sub-polygon structures in ED-2. ! - ! MAXPATCH -- If number of patches in a given site exceeds MAXPATCH, force patch ! - ! fusion. If MAXPATCH is 0, then fusion will never happen. If MAXPATCH ! - ! is negative, then the absolute value is used only during the ! - ! initialization, and fusion will never happen again. Notice that if the ! - ! patches are too different, then the actual number of patches in a site ! - ! may exceed MAXPATCH. ! - ! MAXCOHORT -- If number of cohorts in a given patch exceeds MAXCOHORT, force cohort ! - ! fusion. If MAXCOHORT is 0, then fusion will never happen. If MAXCOHORT ! - ! is negative, then the absolute value is used only during the ! - ! initialization, and fusion will never happen again. Notice that if the ! - ! cohorts are too different, then the actual number of cohorts in a patch ! - ! may exceed MAXCOHORT. ! - !---------------------------------------------------------------------------------------! - MAXPATCH = 10, - MAXCOHORT = 60, + ! MAXPATCH -- If number of patches in a given site exceeds MAXPATCH, force patch ! + ! fusion. If MAXPATCH is 0, then fusion will never happen. If ! + ! MAXPATCH is negative, then the absolute value is used only during ! + ! the initialization, and fusion will never happen again. Notice ! + ! that if the patches are too different, then the actual number of ! + ! patches in a site may exceed MAXPATCH. ! + ! MAXCOHORT -- If number of cohorts in a given patch exceeds MAXCOHORT, force ! + ! cohort fusion. If MAXCOHORT is 0, then fusion will never happen. ! + ! If MAXCOHORT is negative, then the absolute value is used only ! + ! during the initialization, and fusion will never happen again. ! + ! Notice that if the cohorts are too different, then the actual ! + ! number of cohorts in a patch may exceed MAXCOHORT. ! + ! MIN_PATCH_AREA -- This is the minimum fraction area of a given soil type that allows ! + ! a site to be created (ignored if IED_INIT_MODE is set to 3). ! + !---------------------------------------------------------------------------------------! + MAXPATCH = 10, + MAXCOHORT = 60, + MIN_PATCH_AREA = 0.005, !---------------------------------------------------------------------------------------! diff --git a/BRAMS/Template/setup.sh b/BRAMS/Template/setup.sh index 2859d0978..3cc742b6e 100755 --- a/BRAMS/Template/setup.sh +++ b/BRAMS/Template/setup.sh @@ -6,10 +6,10 @@ #------------------------------------------------------------------------------------------# here=`pwd` # Local disk moi=`whoami` # User name -diskthere='/n/scratch2/moorcroft_lab' # Output directory +diskthere='/n/moorcroftfs2' # Output directory queue='camd' # Queue to be used -whena='08-01-2008 00:00' # Initial time for simulation -whenz='09-01-2008 00:00' # Final time for simulation +whena='01-01-2008 00:00' # Initial time for simulation +whenz='01-01-2009 00:00' # Final time for simulation isfcl=5 # 1 = LEAF-3 run, 5 = ED-2.2 run #------------------------------------------------------------------------------------------# @@ -192,7 +192,8 @@ then elif [ ! -s ${there} ] then mv tothere ${there} -else +elif [ ${here} != ${there} ] +then echo ' There is already a directory called '${there}'...' echo ' Do you want to delete it? [y/N]' read proceed @@ -232,6 +233,8 @@ else rm -frv ${there} mv tothere ${there} +else + mv tothere/* . fi #------------------------------------------------------------------------------------------# diff --git a/BRAMS/Template/tothere/rpost/1eachtime-sigma.sh b/BRAMS/Template/tothere/rpost/1eachtime-sigma.sh index e7cfc385e..ec6916165 100755 --- a/BRAMS/Template/tothere/rpost/1eachtime-sigma.sh +++ b/BRAMS/Template/tothere/rpost/1eachtime-sigma.sh @@ -11,18 +11,18 @@ #------------------------------------------------------------------------------------------# # CHANGE LOG # #------------------------------------------------------------------------------------------# -ramspost='myoutpath/rpost/ramspost_6.2' # Name of executable file -tmpfolder='myoutpath/rpost/.temp' # Name of a timestrrary folder +ramspost='/n/moorcroftfs2/mlongo/EDBRAMS/coupled/monotonic-test/rpost/ramspost_6.2' # Name of executable file +tmpfolder='/n/moorcroftfs2/mlongo/EDBRAMS/coupled/monotonic-test/rpost/.temp' # Name of a timestrrary folder nice='' # Command to "nice" the job. Put nothing if you don't want # to be nice -runoutput='myoutpath/rpost/ramspost.out' # Name of a renewable output file +runoutput='/n/moorcroftfs2/mlongo/EDBRAMS/coupled/monotonic-test/rpost/ramspost.out' # Name of a renewable output file compression='none' # Kind of compression:(Z, bz2, zip, gz, or none) title='EDBRAMS-1.4' # Title to appear in the header # (no practical relevance) deleteintctl='y' # Delete intermediate ctl [y/N] # (a template will be provided) outshell='y' -shellout='myoutpath/rpost/serial_out.out' # File for 1eachtime-sigma.sh output +shellout='/n/moorcroftfs2/mlongo/EDBRAMS/coupled/monotonic-test/rpost/serial_out.out' # File for 1eachtime-sigma.sh output #------------------------------------------------------------------------------------------# #------------------------------------------------------------------------------------------# @@ -91,7 +91,7 @@ fi #----- Determine the analysis prefix from the list. ---------------------------------------# -fprefix=`grep -i FPREFIX ramspost.inp` +fprefix=`grep -i FPREFIX ramspost.inp | grep -vi "\-\-"` fprefix=`echo ${fprefix} | sed s/" "/""/g |sed s/"'"/""/g` ext=`echo ${fprefix} |wc -c` p=0 @@ -114,7 +114,7 @@ fprefix=`echo ${fprefix} | awk '{print substr($1,9,'${ext}')}'` #------------------------------------------------------------------------------------------# # Determine the output file prefix from the namelist. # #------------------------------------------------------------------------------------------# -gprefix=`grep -i GPREFIX ramspost.inp` +gprefix=`grep -i GPREFIX ramspost.inp | grep -vi "\-\-"` gprefix=`echo ${gprefix} | sed s/" "/""/g |sed s/"'"/""/g` ext=`echo ${gprefix} |wc -c` p=0 diff --git a/BRAMS/Template/tothere/rpost/ramspost.inp b/BRAMS/Template/tothere/rpost/ramspost.inp index 523f07a36..d1884c630 100644 --- a/BRAMS/Template/tothere/rpost/ramspost.inp +++ b/BRAMS/Template/tothere/rpost/ramspost.inp @@ -1,99 +1,89 @@ - $RP_INPUT - +$RP_INPUT + !--------------------------------------------------------------------------------------! + ! FPREFIX -- Prefix of the input files. ! + !--------------------------------------------------------------------------------------! FPREFIX = 'myoutpath/analy/mysimul-A-', + !--------------------------------------------------------------------------------------! + + !--------------------------------------------------------------------------------------! + ! NVP -- List of variables to be printed. ! + ! VP -- Variable names (only the first NVP variables will be used) ! + !--------------------------------------------------------------------------------------! + NVP = 86, + VP = 'longitude', 'latitude', 'press', 'tempc', 'theta', + 'theiv', 'co2', 'rv', 'liquid', 'ice', + 'cuprliq', 'cuprice', 'areadn', 'areaup', 'wdndraft', + 'wupdraft', 'thsrc', 'rtsrc', 'co2src', 'ue_avg', + 've_avg', 'w_avg', 'tke', 'sigw', 'conprr', + 'dnmf', 'upmf', 'edt', 'ierr', 'aadn', + 'aaup', 'pcprate', 'acccon', 'totpcp', 'pblhgt', + 'zen', 'rshort', 'rshorttoa', 'rshortd', 'albedt', + 'rlong', 'rlongup', 'h', 'evap', 'transp', + 'hflxca', 'qwflxca', 'cflxca', 'land', 'sst', + 'topo', 'lai_ps', 'agb_ps', 'tcan_ps', 'thcan_ps', + 'rvcan_ps', 'pcan_ps', 'co2can_ps', 'tveg_ps', 'ustar_ps', + 'tstar_ps', 'rstar_ps', 'cstar_ps', 'tempc2m', 'tdewc2m', + 'u10m', 'smoist_ps', 'smfrac_ps', 'tsoil_ps', 'sltex_bp', + 'vtype_bp', 'sfcw_mass', 'sfcw_depth', 'sfcw_temp', 'vegz0_ps', + 'z0_ps', 'rib_ps', 'zeta_ps', 'gpp', 'plresp', + 'resphet', 'mynum', 'relvortx', 'relvorty', 'solenoidx', + 'solenoidy', + !--------------------------------------------------------------------------------------! - NVP = 75, - VP ='longitude', - 'latitude', - 'press', - 'tempc', - 'theta', - 'theiv', - 'co2', - 'rv', - 'liquid', - 'ice', - 'ue_avg', - 've_avg', - 'w_avg', - 'relvortx', - 'relvorty', - 'solenoidx', - 'solenoidy', - 'tke', - 'sigw', - 'conprr', - 'dnmf', - 'upmf', - 'aadn', - 'aaup', - 'pcprate', - 'acccon', - 'totpcp', - 'pblhgt', - 'zen', - 'rshort', - 'rshorttoa', - 'rshortd', - 'albedt', - 'rlong', - 'rlongup', - 'h', - 'evap', - 'transp', - 'hflxca', - 'qwflxca', - 'cflxca', - 'land', - 'sst', - 'topo', - 'lai_ps', - 'agb_ps', - 'tcan_ps', - 'thcan_ps', - 'rvcan_ps', - 'pcan_ps', - 'co2can_ps', - 'tveg_ps', - 'ustar_ps', - 'tstar_ps', - 'rstar_ps', - 'cstar_ps', - 'tempc2m', - 'tdewc2m', - 'u10m', - 'smoist_ps', - 'smfrac_ps', - 'tsoil_ps', - 'sltex_bp', - 'vtype_bp', - 'sfcw_mass', - 'sfcw_depth', - 'sfcw_temp', - 'vegz0_ps', - 'z0_ps', - 'rib_ps', - 'zeta_ps', - 'gpp', - 'plresp', - 'resphet', - 'mynum', + !--------------------------------------------------------------------------------------! + ! GPREFIX -- Prefix of the output files. ! + !--------------------------------------------------------------------------------------! GPREFIX = 'binary/mysimul', + !--------------------------------------------------------------------------------------! + + + + !--------------------------------------------------------------------------------------! + ! NSTEP -- number of steps to use. If 1, every step is used; if 2, every other step ! + ! is used; if 3, one step is used and two are skipped; and so on... ! + !--------------------------------------------------------------------------------------! + NSTEP = 1, + !--------------------------------------------------------------------------------------! + + + + !--------------------------------------------------------------------------------------! + ! PROJ -- Should the files be projected to true lon/lat grid points (yes or no, case ! + ! insensitive). ! + !--------------------------------------------------------------------------------------! + PROJ = 'no', + !--------------------------------------------------------------------------------------! + + + !--------------------------------------------------------------------------------------! + ! LATI -- Southernmost latitude to consider (one value per grid). ! + ! LATF -- Northernmost latitude to consider (one value per grid). ! + ! LONI -- Westernmost longitude to consider (one value per grid). ! + ! LONI -- Easternmost longitude to consider (one value per grid). ! + !--------------------------------------------------------------------------------------! + LATI = -90., -90., -90., + LATF = +90., +90., +90., + LONI = -180.,-180., -180., + LONF = 180., 180., 180., + !--------------------------------------------------------------------------------------! - ANL2GRA='ALL', - PROJ='NO', - LATI = -90.,-90., -90., - LATF = +90.,+90., +90., - LONI = -180.,-180., -180., - LONF = 180.,180., 180., - - - ZLEVMAX = 51,51,51, - IPRESSLEV = 0, - INPLEVS = 12, - IPLEVS = 2, 4, 6,7,8, 10, 12,14, 16,19,21, 23, - 1000,975,950,925,900,850,800,750,700,500,300,200, - - $end + !--------------------------------------------------------------------------------------! + ! ZLEVMAX -- Maximum number of levels to output ! + ! IPRESSLEV -- Type of vertical coordinate: ! + ! 0. Native (sigma-z or shaved-eta) ! + ! 1. Pressure levels ! + ! 2. Height levels ! + ! INPLEVS -- In case ipresslev is 1 or 2, the number of prescribed levels ! + ! IPLEVS -- The height levels (N.B. they must be integers) ! + ! If IPRESSLEV = 1, IPLEVS are pressure levels in hPa ! + ! IPRESSLEV = 2, IPLEVS are the height levels in m above sea level. ! + !--------------------------------------------------------------------------------------! + ZLEVMAX = 51, 51, 51, + IPRESSLEV = 0, + INPLEVS = 19, + IPLEVS = 1000, 975, 950, 925, 900, 850, 800, 750, 700, 600, + 500, 400, 300, 250, 200, 150, 100, 85, 70, + !--------------------------------------------------------------------------------------! +$END diff --git a/BRAMS/build/bin/2ndcomp.sh b/BRAMS/build/bin/2ndcomp.sh index a40849838..789605a96 100755 --- a/BRAMS/build/bin/2ndcomp.sh +++ b/BRAMS/build/bin/2ndcomp.sh @@ -103,6 +103,7 @@ rm -fv mem_mass.o mem_mass.mod rm -fv mem_mclat.o mem_mclat.mod rm -fv mem_micro.o mem_micro.mod rm -fv mem_mksfc.o mem_mksfc.mod +rm -fv mem_mnt_advec.o mem_mnt_advec.mod rm -fv mem_nestb.o mem_nestb.mod rm -fv mem_oda.o mem_oda.mod rm -fv mem_opt_scratch.o mem_opt_scratch.mod @@ -143,12 +144,15 @@ rm -fv mksfc_ndvi.o mksfc_ndvi.mod rm -fv mksfc_sfc.o mksfc_sfc.mod rm -fv mksfc_sst.o mksfc_sst.mod rm -fv mksfc_top.o mksfc_top.mod +rm -fv mnt_advec_aux.o mnt_advec_aux.mod +rm -fv mnt_advec_main.o mnt_advec_main.mod rm -fv mod_advect_kit.o mod_advect_kit.mod rm -fv mod_GhostBlock.o mod_GhostBlock.mod rm -fv mod_GhostBlockPartition.o mod_GhostBlockPartition.mod rm -fv mod_ozone.o mod_ozone.mod rm -fv model.o model.mod rm -fv modsched.o modsched.mod +rm -fv mpass_advec.o mpass_advec.mod rm -fv mpass_cyclic.o mpass_cyclic.mod rm -fv mpass_dtl.o mpass_dtl.mod rm -fv mpass_feed.o mpass_feed.mod @@ -275,6 +279,7 @@ rm -fv lake_coms.o lake_coms.mod rm -fv mem_edcp.o mem_edcp.mod rm -fv allometry.o allometry.mod rm -fv average_utils.o average_utils.mod +rm -fv bdf2_solver.o bdf2_solver.mod rm -fv budget_utils.o budget_utils.mod rm -fv c34constants.o c34constants.mod rm -fv canopy_air_coms.o canopy_air_coms.mod @@ -283,6 +288,7 @@ rm -fv canopy_radiation_coms.o canopy_radiation_coms.mod rm -fv canopy_struct_dynamics.o canopy_struct_dynamics.mod rm -fv consts_coms.o consts_coms.mod rm -fv decomp_coms.o decomp_coms.mod +rm -fv detailed_coms.o detailed_coms.mod rm -fv disturb_coms.o disturb_coms.mod rm -fv disturbance.o disturbance.mod rm -fv ed_bare_restart.o ed_bare_restart.mod @@ -320,6 +326,7 @@ rm -fv grid_coms.o grid_coms.mod rm -fv growth_balive.o growth_balive.mod rm -fv h5_output.o h5_output.mod rm -fv heun_driver.o heun_driver.mod +rm -fv hybrid_driver.o hybrid_driver.mod rm -fv hydrology_coms.o hydrology_coms.mod rm -fv hydrology_constants.o hydrology_constants.mod rm -fv init_hydro_sites.o init_hydro_sites.mod diff --git a/BRAMS/build/bin/dependency.mk b/BRAMS/build/bin/dependency.mk index 7e00c2d2a..e1527ea0d 100644 --- a/BRAMS/build/bin/dependency.mk +++ b/BRAMS/build/bin/dependency.mk @@ -1,10 +1,4 @@ # DO NOT DELETE THIS LINE - used by make depend -error_mod.o: grid_dims.mod -gridteste.o: boundarymod.mod gridmod.mod mapmod.mod processormod.mod -init_advect.o: advmessagemod.mod boundarymod.mod errormod.mod gridmod.mod -init_advect.o: mapmod.mod processormod.mod -radvc_mnt.o: adv_message_mod.mod mem_basic.mod mem_grid.mod mem_scratch.mod -radvc_mnt.o: node_mod.mod rconstants.mod therm_lib.mod var_tables.mod cyclic_mod.o: grid_dims.mod rbnd.o: catt_start.mod mem_basic.mod mem_grid.mod mem_scratch.mod mem_tend.mod rbnd.o: mem_turb.mod node_mod.mod ref_sounding.mod therm_lib.mod var_tables.mod @@ -20,7 +14,7 @@ plumerise_vector.o: node_mod.mod rconstants.mod therm_lib.mod coriolis.o: mem_basic.mod mem_grid.mod mem_scratch.mod mem_tend.mod coriolis.o: rconstants.mod ref_sounding.mod local_proc.o: io_params.mod mem_grid.mod node_mod.mod rconstants.mod -local_proc.o: ref_sounding.mod rpara.mod +local_proc.o: ref_sounding.mod rpara.mod therm_lib.mod mod_GhostBlock.o: mod_ghostblockpartition.mod mod_advect_kit.o: mem_basic.mod mem_grid.mod mem_tend.mod mod_ghostblock.mod mod_advect_kit.o: mod_ghostblockpartition.mod node_mod.mod var_tables.mod @@ -31,9 +25,6 @@ raco.o: mem_basic.mod mem_grid.mod mem_scratch.mod mem_tend.mod node_mod.mod raco.o: rconstants.mod therm_lib.mod raco_adap.o: mem_grid.mod mem_scratch.mod node_mod.mod rconstants.mod radvc.o: mem_basic.mod mem_grid.mod mem_scratch.mod mem_tend.mod var_tables.mod -radvc_mnt.o: advmessagemod.mod mem_basic.mod mem_chem1.mod mem_grid.mod -radvc_mnt.o: mem_scratch.mod micphys.mod node_mod.mod rconstants.mod -radvc_mnt.o: var_tables.mod rams_master.o: catt_start.mod dtset.mod emission_source_map.mod grid_dims.mod rams_master.o: io_params.mod mem_cuparm.mod mem_emiss.mod mem_grid.mod rams_master.o: mem_leaf.mod mem_mass.mod mem_oda.mod mem_radiate.mod @@ -46,8 +37,8 @@ rthrm.o: mem_basic.mod mem_grid.mod mem_micro.mod mem_scratch.mod micphys.mod rthrm.o: node_mod.mod rconstants.mod therm_lib.mod rtimh.o: advect_kit.mod catt_start.mod emission_source_map.mod mem_all.mod rtimh.o: mem_basic.mod mem_cuparm.mod mem_emiss.mod mem_grid.mod mem_leaf.mod -rtimh.o: mem_mass.mod mem_oda.mod mem_scalar.mod mem_turb.mod mem_varinit.mod -rtimh.o: node_mod.mod teb_spm_start.mod therm_lib.mod +rtimh.o: mem_mass.mod mem_mnt_advec.mod mem_oda.mod mem_scalar.mod mem_turb.mod +rtimh.o: mem_varinit.mod node_mod.mod teb_spm_start.mod therm_lib.mod rtimi.o: mem_basic.mod mem_grid.mod mem_scratch.mod mem_tend.mod node_mod.mod rtimi.o: var_tables.mod cu_read.o: grid_dims.mod mem_basic.mod mem_cuparm.mod mem_grid.mod @@ -60,12 +51,13 @@ grell_cupar_driver.o: mem_basic.mod mem_cuparm.mod mem_ensemble.mod mem_grid.mod grell_cupar_driver.o: mem_mass.mod mem_micro.mod mem_scalar.mod mem_scratch.mod grell_cupar_driver.o: mem_scratch_grell.mod mem_tend.mod mem_turb.mod grell_cupar_driver.o: micphys.mod node_mod.mod therm_lib.mod -grell_cupar_dynamic.o: grell_coms.mod mem_ensemble.mod mem_scratch_grell.mod -grell_cupar_dynamic.o: rconstants.mod +grell_cupar_dynamic.o: grell_coms.mod grid_dims.mod mem_ensemble.mod +grell_cupar_dynamic.o: mem_scratch_grell.mod rconstants.mod therm_lib.mod grell_cupar_ensemble.o: rconstants.mod grell_cupar_environment.o: grell_coms.mod rconstants.mod therm_lib.mod grell_cupar_feedback.o: mem_ensemble.mod mem_scratch_grell.mod rconstants.mod -grell_cupar_static.o: mem_ensemble.mod mem_scratch_grell.mod rconstants.mod +grell_cupar_static.o: grid_dims.mod mem_ensemble.mod mem_scratch_grell.mod +grell_cupar_static.o: rconstants.mod therm_lib.mod grell_cupar_updraft.o: mem_cuparm.mod rconstants.mod therm_lib.mod grell_extras_catt.o: grell_coms.mod mem_basic.mod mem_ensemble.mod mem_grid.mod grell_extras_catt.o: mem_scalar.mod mem_scratch.mod mem_scratch_grell.mod @@ -80,10 +72,12 @@ shcu_vars_const.o: conv_coms.mod grid_dims.mod souza_cupar_driver.o: conv_coms.mod mem_basic.mod mem_cuparm.mod mem_grid.mod souza_cupar_driver.o: mem_micro.mod mem_scratch.mod mem_tend.mod mem_turb.mod souza_cupar_driver.o: node_mod.mod shcu_vars_const.mod therm_lib.mod +~grell_cupar_static.o: grid_dims.mod mem_ensemble.mod mem_scratch_grell.mod +~grell_cupar_static.o: rconstants.mod therm_lib.mod edcp_driver.o: consts_coms.mod ed_misc_coms.mod ed_node_coms.mod edcp_driver.o: ed_state_vars.mod ed_work_vars.mod grid_coms.mod io_params.mod -edcp_driver.o: leaf_coms.mod mem_edcp.mod mem_grid.mod mem_leaf.mod rk4_coms.mod -edcp_driver.o: soil_coms.mod +edcp_driver.o: leaf_coms.mod mem_edcp.mod mem_grid.mod mem_leaf.mod +edcp_driver.o: phenology_aux.mod rk4_coms.mod soil_coms.mod edcp_init.o: ed_max_dims.mod ed_node_coms.mod ed_para_coms.mod ed_state_vars.mod edcp_init.o: ed_work_vars.mod grid_coms.mod mem_grid.mod mem_leaf.mod edcp_init.o: mem_polygons.mod node_mod.mod rpara.mod soil_coms.mod @@ -98,12 +92,12 @@ edcp_lake_misc.o: rk4_coms.mod therm_lib8.mod edcp_lake_stepper.o: ed_misc_coms.mod lake_coms.mod rk4_coms.mod edcp_load_namelist.o: canopy_air_coms.mod canopy_layer_coms.mod edcp_load_namelist.o: canopy_radiation_coms.mod consts_coms.mod decomp_coms.mod -edcp_load_namelist.o: disturb_coms.mod ed_max_dims.mod ed_misc_coms.mod -edcp_load_namelist.o: grid_coms.mod grid_dims.mod io_params.mod leaf_coms.mod -edcp_load_namelist.o: mem_edcp.mod mem_grid.mod mem_leaf.mod mem_polygons.mod -edcp_load_namelist.o: mem_radiate.mod met_driver_coms.mod optimiz_coms.mod -edcp_load_namelist.o: pft_coms.mod phenology_coms.mod physiology_coms.mod -edcp_load_namelist.o: rk4_coms.mod soil_coms.mod +edcp_load_namelist.o: detailed_coms.mod disturb_coms.mod ed_max_dims.mod +edcp_load_namelist.o: ed_misc_coms.mod grid_coms.mod grid_dims.mod io_params.mod +edcp_load_namelist.o: leaf_coms.mod mem_edcp.mod mem_grid.mod mem_leaf.mod +edcp_load_namelist.o: mem_polygons.mod mem_radiate.mod met_driver_coms.mod +edcp_load_namelist.o: optimiz_coms.mod pft_coms.mod phenology_coms.mod +edcp_load_namelist.o: physiology_coms.mod rk4_coms.mod soil_coms.mod edcp_met.o: canopy_radiation_coms.mod ed_max_dims.mod ed_misc_coms.mod edcp_met.o: ed_node_coms.mod ed_state_vars.mod leaf_coms.mod mem_basic.mod edcp_met.o: mem_cuparm.mod mem_edcp.mod mem_grid.mod mem_leaf.mod mem_micro.mod @@ -111,17 +105,17 @@ edcp_met.o: mem_radiate.mod mem_turb.mod met_driver_coms.mod micphys.mod edcp_met.o: node_mod.mod rconstants.mod soil_coms.mod therm_lib.mod edcp_met_init.o: ed_state_vars.mod ed_therm_lib.mod grid_coms.mod leaf_coms.mod edcp_met_init.o: mem_grid.mod mem_leaf.mod mem_radiate.mod rconstants.mod -edcp_met_init.o: soil_coms.mod therm_lib.mod therm_lib8.mod +edcp_met_init.o: soil_coms.mod therm_lib.mod edcp_model.o: consts_coms.mod ed_max_dims.mod ed_misc_coms.mod ed_node_coms.mod edcp_model.o: ed_state_vars.mod grid_coms.mod grid_dims.mod io_params.mod edcp_model.o: mem_edcp.mod mem_grid.mod mem_polygons.mod rk4_coms.mod edcp_model.o: rk4_driver.mod edcp_mpiutils.o: canopy_air_coms.mod canopy_layer_coms.mod -edcp_mpiutils.o: canopy_radiation_coms.mod decomp_coms.mod disturb_coms.mod -edcp_mpiutils.o: ed_max_dims.mod ed_misc_coms.mod grid_coms.mod mem_edcp.mod -edcp_mpiutils.o: mem_polygons.mod met_driver_coms.mod optimiz_coms.mod -edcp_mpiutils.o: pft_coms.mod phenology_coms.mod physiology_coms.mod -edcp_mpiutils.o: rk4_coms.mod soil_coms.mod +edcp_mpiutils.o: canopy_radiation_coms.mod decomp_coms.mod detailed_coms.mod +edcp_mpiutils.o: disturb_coms.mod ed_max_dims.mod ed_misc_coms.mod grid_coms.mod +edcp_mpiutils.o: mem_edcp.mod mem_polygons.mod met_driver_coms.mod +edcp_mpiutils.o: optimiz_coms.mod pft_coms.mod phenology_coms.mod +edcp_mpiutils.o: physiology_coms.mod rk4_coms.mod soil_coms.mod edcp_para_init.o: ed_misc_coms.mod ed_node_coms.mod ed_work_vars.mod edcp_para_init.o: io_params.mod mem_grid.mod mem_leaf.mod mem_polygons.mod edcp_para_init.o: node_mod.mod soil_coms.mod @@ -157,11 +151,12 @@ rams_grid.o: mem_grid.mod node_mod.mod rconstants.mod rdint.o: catt_start.mod domain_decomp.mod emission_source_map.mod grell_coms.mod rdint.o: grid_dims.mod io_params.mod isan_coms.mod leaf_coms.mod mem_basic.mod rdint.o: mem_cuparm.mod mem_emiss.mod mem_gaspart.mod mem_grid.mod mem_leaf.mod -rdint.o: mem_mass.mod mem_micro.mod mem_oda.mod mem_radiate.mod mem_scalar.mod -rdint.o: mem_scratch.mod mem_soil_moisture.mod mem_teb.mod mem_teb_common.mod -rdint.o: mem_turb.mod mem_varinit.mod micphys.mod node_mod.mod plume_utils.mod -rdint.o: rconstants.mod ref_sounding.mod teb_spm_start.mod teb_vars_const.mod -rdint.o: therm_lib.mod therm_lib8.mod turb_coms.mod var_tables.mod +rdint.o: mem_mass.mod mem_micro.mod mem_mnt_advec.mod mem_oda.mod +rdint.o: mem_radiate.mod mem_scalar.mod mem_scratch.mod mem_soil_moisture.mod +rdint.o: mem_teb.mod mem_teb_common.mod mem_turb.mod mem_varinit.mod micphys.mod +rdint.o: node_mod.mod plume_utils.mod rconstants.mod ref_sounding.mod +rdint.o: teb_spm_start.mod teb_vars_const.mod therm_lib.mod therm_lib8.mod +rdint.o: turb_coms.mod var_tables.mod rhhi.o: mem_basic.mod mem_grid.mod mem_scratch.mod rconstants.mod rhhi.o: ref_sounding.mod therm_lib.mod rinit.o: io_params.mod mem_basic.mod mem_grid.mod mem_micro.mod mem_scratch.mod @@ -174,13 +169,13 @@ inithis.o: var_tables.mod io_params.o: grid_dims.mod opspec.o: catt_start.mod grell_coms.mod io_params.mod leaf_coms.mod opspec.o: mem_basic.mod mem_cuparm.mod mem_emiss.mod mem_grid.mod mem_leaf.mod -opspec.o: mem_mass.mod mem_radiate.mod mem_turb.mod mem_varinit.mod micphys.mod -opspec.o: teb_spm_start.mod therm_lib.mod +opspec.o: mem_mass.mod mem_mnt_advec.mod mem_radiate.mod mem_turb.mod +opspec.o: mem_varinit.mod micphys.mod teb_spm_start.mod therm_lib.mod rams_read_header.o: an_header.mod grid_dims.mod ranlavg.o: io_params.mod mem_basic.mod mem_grid.mod mem_scratch.mod mem_turb.mod ranlavg.o: node_mod.mod var_tables.mod rcio.o: grell_coms.mod grid_dims.mod leaf_coms.mod mem_all.mod mem_mass.mod -rcio.o: therm_lib.mod turb_coms.mod +rcio.o: mem_mnt_advec.mod therm_lib.mod turb_coms.mod recycle.o: grid_dims.mod io_params.mod mem_aerad.mod mem_cuparm.mod mem_grid.mod recycle.o: mem_leaf.mod mem_scratch.mod var_tables.mod rhdf5.o: an_header.mod grid_dims.mod io_params.mod mem_aerad.mod @@ -189,8 +184,9 @@ rio.o: an_header.mod grid_dims.mod io_params.mod mem_aerad.mod mem_basic.mod rio.o: mem_cuparm.mod mem_grid.mod mem_scratch.mod mem_turb.mod rconstants.mod rio.o: ref_sounding.mod therm_lib.mod var_tables.mod rname.o: catt_start.mod domain_decomp.mod emission_source_map.mod grell_coms.mod -rname.o: leaf_coms.mod mem_all.mod mem_mass.mod mem_soil_moisture.mod -rname.o: plume_utils.mod teb_spm_start.mod therm_lib.mod turb_coms.mod +rname.o: leaf_coms.mod mem_all.mod mem_mass.mod mem_mnt_advec.mod +rname.o: mem_soil_moisture.mod plume_utils.mod teb_spm_start.mod therm_lib.mod +rname.o: turb_coms.mod rprnt.o: io_params.mod leaf_coms.mod mem_all.mod mem_basic.mod mem_grid.mod rprnt.o: mem_leaf.mod mem_scratch.mod mem_turb.mod rconstants.mod rprnt.o: ref_sounding.mod therm_lib.mod var_tables.mod @@ -228,8 +224,9 @@ rmass.o: mem_grid.mod mem_mass.mod mem_scratch.mod mem_scratch_grell.mod rmass.o: mem_turb.mod dealloc.o: catt_start.mod mem_aerad.mod mem_all.mod mem_ensemble.mod dealloc.o: mem_gaspart.mod mem_globaer.mod mem_globrad.mod mem_mass.mod -dealloc.o: mem_opt.mod mem_scratch1_grell.mod mem_scratch_grell.mod mem_teb.mod -dealloc.o: mem_teb_common.mod mem_tend.mod teb_spm_start.mod +dealloc.o: mem_mnt_advec.mod mem_opt.mod mem_scratch1_grell.mod +dealloc.o: mem_scratch_grell.mod mem_teb.mod mem_teb_common.mod mem_tend.mod +dealloc.o: teb_spm_start.mod hdf5_coms.o: mem_all.o: io_params.mod mem_basic.mod mem_cuparm.mod mem_grid.mod mem_leaf.mod mem_all.o: mem_micro.mod mem_nestb.mod mem_oda.mod mem_radiate.mod @@ -248,18 +245,18 @@ rams_mem_alloc.o: catt_start.mod extras.mod grell_coms.mod io_params.mod rams_mem_alloc.o: leaf_coms.mod machine_arq.mod mem_aerad.mod mem_all.mod rams_mem_alloc.o: mem_carma.mod mem_emiss.mod mem_ensemble.mod mem_gaspart.mod rams_mem_alloc.o: mem_globaer.mod mem_globrad.mod mem_grell_param.mod -rams_mem_alloc.o: mem_grid_dim_defs.mod mem_mass.mod mem_opt.mod mem_scalar.mod -rams_mem_alloc.o: mem_scratch1_grell.mod mem_scratch2_grell.mod -rams_mem_alloc.o: mem_scratch2_grell_sh.mod mem_scratch3_grell.mod -rams_mem_alloc.o: mem_scratch3_grell_sh.mod mem_scratch_grell.mod mem_teb.mod -rams_mem_alloc.o: mem_teb_common.mod mem_turb_scalar.mod node_mod.mod -rams_mem_alloc.o: teb_spm_start.mod teb_vars_const.mod turb_coms.mod +rams_mem_alloc.o: mem_grid_dim_defs.mod mem_mass.mod mem_mnt_advec.mod +rams_mem_alloc.o: mem_opt.mod mem_scalar.mod mem_scratch1_grell.mod +rams_mem_alloc.o: mem_scratch2_grell.mod mem_scratch2_grell_sh.mod +rams_mem_alloc.o: mem_scratch3_grell.mod mem_scratch3_grell_sh.mod +rams_mem_alloc.o: mem_scratch_grell.mod mem_teb.mod mem_teb_common.mod +rams_mem_alloc.o: mem_turb_scalar.mod node_mod.mod teb_spm_start.mod +rams_mem_alloc.o: teb_vars_const.mod turb_coms.mod vtab_fill.o: grid_dims.mod io_params.mod var_tables.mod mem_micro.o: micphys.mod therm_lib.mod var_tables.mod mic_coll.o: micphys.mod micro_coms.mod rconstants.mod therm_lib.mod -mic_driv.o: grid_dims.mod mem_basic.mod mem_grid.mod mem_micro.mod -mic_driv.o: mem_scratch.mod micphys.mod micro_coms.mod node_mod.mod -mic_driv.o: rconstants.mod therm_lib.mod +mic_driv.o: grid_dims.mod mem_basic.mod mem_grid.mod mem_micro.mod micphys.mod +mic_driv.o: micro_coms.mod node_mod.mod therm_lib.mod mic_gamma.o: rconstants.mod therm_lib.mod mic_init.o: grid_dims.mod mem_grid.mod mem_radiate.mod micphys.mod mic_init.o: micro_coms.mod node_mod.mod rconstants.mod therm_lib.mod @@ -289,6 +286,12 @@ nest_geosst.o: mem_leaf.mod mem_mksfc.mod mem_radiate.mod mem_scratch.mod nest_geosst.o: mem_soil_moisture.mod nest_init_aux.o: mem_basic.mod mem_grid.mod mem_leaf.mod mem_scratch.mod sst_read.o: grid_dims.mod io_params.mod mem_grid.mod mem_leaf.mod +mem_mnt_advec.o: var_tables.mod +mnt_advec_aux.o: mem_grid.mod rconstants.mod therm_lib.mod +mnt_advec_main.o: grid_dims.mod mem_basic.mod mem_grid.mod mem_mnt_advec.mod +mnt_advec_main.o: mem_scratch.mod therm_lib.mod var_tables.mod +mpass_advec.o: grid_dims.mod mem_aerad.mod mem_cuparm.mod mem_grid.mod +mpass_advec.o: mem_scratch.mod node_mod.mod var_tables.mod mpass_cyclic.o: cyclic_mod.mod grid_dims.mod mem_aerad.mod mem_basic.mod mpass_cyclic.o: mem_cuparm.mod mem_grid.mod mem_scratch.mod node_mod.mod mpass_cyclic.o: var_tables.mod @@ -300,9 +303,10 @@ mpass_full.o: mem_grid.mod mem_scratch.mod mem_varinit.mod node_mod.mod mpass_full.o: rpara.mod var_tables.mod mpass_init.o: catt_start.mod cyclic_mod.mod emission_source_map.mod mpass_init.o: grell_coms.mod grid_dims.mod leaf_coms.mod mem_all.mod -mpass_init.o: mem_cuparm.mod mem_emiss.mod mem_grid.mod mem_mass.mod micphys.mod -mpass_init.o: node_mod.mod plume_utils.mod ref_sounding.mod rpara.mod -mpass_init.o: teb_spm_start.mod teb_vars_const.mod therm_lib.mod turb_coms.mod +mpass_init.o: mem_cuparm.mod mem_emiss.mod mem_grid.mod mem_mass.mod +mpass_init.o: mem_mnt_advec.mod micphys.mod node_mod.mod plume_utils.mod +mpass_init.o: ref_sounding.mod rpara.mod teb_spm_start.mod teb_vars_const.mod +mpass_init.o: therm_lib.mod turb_coms.mod mpass_lbc.o: grid_dims.mod mem_aerad.mod mem_cuparm.mod mem_grid.mod mpass_lbc.o: mem_scratch.mod node_mod.mod var_tables.mod mpass_nest.o: grid_dims.mod mem_basic.mod mem_grid.mod mem_nestb.mod @@ -362,7 +366,7 @@ mem_mclat.o: rconstants.mod mem_radiate.o: var_tables.mod rad_carma.o: catt_start.mod grid_dims.mod mem_aerad.mod mem_carma.mod rad_carma.o: mem_globaer.mod mem_globrad.mod mem_grid.mod mem_radiate.mod -rad_carma.o: node_mod.mod rconstants.mod +rad_carma.o: node_mod.mod rconstants.mod therm_lib.mod rad_ccmp.o: rconstants.mod rad_driv.o: catt_start.mod mem_basic.mod mem_cuparm.mod mem_grid.mod rad_driv.o: mem_harr.mod mem_leaf.mod mem_mclat.mod mem_micro.mod @@ -374,6 +378,7 @@ rad_mclat.o: rconstants.mod mem_soil_moisture.o: grid_dims.mod leaf_coms.mod soil_moisture_init.o: grid_dims.mod io_params.mod leaf_coms.mod mem_grid.mod soil_moisture_init.o: mem_leaf.mod mem_soil_moisture.mod rconstants.mod +soil_moisture_init.o: therm_lib.mod leaf3.o: io_params.mod leaf_coms.mod mem_basic.mod mem_cuparm.mod mem_grid.mod leaf3.o: mem_leaf.mod mem_micro.mod mem_radiate.mod mem_scratch.mod mem_teb.mod leaf3.o: mem_teb_common.mod mem_turb.mod node_mod.mod rconstants.mod @@ -429,28 +434,33 @@ turb_k.o: mem_turb_scalar.mod node_mod.mod therm_lib.mod var_tables.mod turb_ke.o: ke_coms.mod mem_grid.mod mem_scratch.mod mem_turb.mod rconstants.mod turb_ke.o: turb_coms.mod ed_1st.o: ed_misc_coms.mod ed_para_coms.mod ed_state_vars.mod -ed_driver.o: consts_coms.mod ed_misc_coms.mod ed_node_coms.mod ed_state_vars.mod -ed_driver.o: fuse_fiss_utils.mod grid_coms.mod soil_coms.mod +ed_driver.o: consts_coms.mod detailed_coms.mod ed_misc_coms.mod ed_node_coms.mod +ed_driver.o: ed_state_vars.mod fuse_fiss_utils.mod grid_coms.mod +ed_driver.o: phenology_aux.mod soil_coms.mod ed_met_driver.o: canopy_air_coms.mod canopy_radiation_coms.mod consts_coms.mod ed_met_driver.o: ed_max_dims.mod ed_misc_coms.mod ed_node_coms.mod ed_met_driver.o: ed_state_vars.mod grid_coms.mod hdf5_utils.mod mem_polygons.mod ed_met_driver.o: met_driver_coms.mod pft_coms.mod therm_lib.mod -ed_model.o: consts_coms.mod disturb_coms.mod ed_misc_coms.mod ed_node_coms.mod -ed_model.o: ed_state_vars.mod grid_coms.mod mem_polygons.mod rk4_coms.mod -ed_model.o: rk4_driver.mod +ed_model.o: consts_coms.mod ed_misc_coms.mod ed_node_coms.mod ed_state_vars.mod +ed_model.o: grid_coms.mod mem_polygons.mod rk4_coms.mod rk4_driver.mod +bdf2_solver.o: consts_coms.mod ed_misc_coms.mod ed_state_vars.mod +bdf2_solver.o: ed_therm_lib.mod grid_coms.mod rk4_coms.mod soil_coms.mod +bdf2_solver.o: therm_lib8.mod canopy_struct_dynamics.o: allometry.mod canopy_air_coms.mod canopy_struct_dynamics.o: canopy_layer_coms.mod consts_coms.mod canopy_struct_dynamics.o: ed_state_vars.mod grid_coms.mod met_driver_coms.mod -canopy_struct_dynamics.o: pft_coms.mod physiology_coms.mod rk4_coms.mod -canopy_struct_dynamics.o: soil_coms.mod +canopy_struct_dynamics.o: pft_coms.mod phenology_coms.mod physiology_coms.mod +canopy_struct_dynamics.o: rk4_coms.mod soil_coms.mod therm_lib.mod disturbance.o: allometry.mod consts_coms.mod decomp_coms.mod disturb_coms.mod disturbance.o: ed_max_dims.mod ed_misc_coms.mod ed_state_vars.mod disturbance.o: ed_therm_lib.mod fuse_fiss_utils.mod grid_coms.mod -disturbance.o: mem_polygons.mod pft_coms.mod phenology_coms.mod -euler_driver.o: canopy_air_coms.mod canopy_struct_dynamics.mod consts_coms.mod -euler_driver.o: ed_max_dims.mod ed_misc_coms.mod ed_state_vars.mod grid_coms.mod +disturbance.o: mem_polygons.mod pft_coms.mod phenology_aux.mod +disturbance.o: phenology_coms.mod +euler_driver.o: canopy_air_coms.mod consts_coms.mod ed_max_dims.mod +euler_driver.o: ed_misc_coms.mod ed_state_vars.mod grid_coms.mod euler_driver.o: hydrology_coms.mod met_driver_coms.mod rk4_coms.mod -euler_driver.o: rk4_driver.mod rk4_stepper.mod soil_coms.mod +euler_driver.o: rk4_driver.mod rk4_stepper.mod soil_coms.mod therm_lib.mod +euler_driver.o: therm_lib8.mod events.o: allometry.mod consts_coms.mod decomp_coms.mod disturbance_utils.mod events.o: ed_misc_coms.mod ed_state_vars.mod ed_therm_lib.mod events.o: fuse_fiss_utils.mod grid_coms.mod pft_coms.mod therm_lib.mod @@ -459,14 +469,19 @@ farq_leuning.o: physiology_coms.mod rk4_coms.mod therm_lib8.mod fire.o: allometry.mod consts_coms.mod disturb_coms.mod ed_misc_coms.mod fire.o: ed_state_vars.mod grid_coms.mod soil_coms.mod forestry.o: allometry.mod disturb_coms.mod disturbance_utils.mod ed_max_dims.mod -forestry.o: ed_state_vars.mod fuse_fiss_utils.mod grid_coms.mod +forestry.o: ed_misc_coms.mod ed_state_vars.mod fuse_fiss_utils.mod grid_coms.mod growth_balive.o: allometry.mod consts_coms.mod decomp_coms.mod ed_max_dims.mod growth_balive.o: ed_misc_coms.mod ed_state_vars.mod ed_therm_lib.mod growth_balive.o: grid_coms.mod mortality.mod pft_coms.mod physiology_coms.mod -heun_driver.o: canopy_air_coms.mod canopy_struct_dynamics.mod consts_coms.mod -heun_driver.o: ed_max_dims.mod ed_misc_coms.mod ed_state_vars.mod grid_coms.mod +heun_driver.o: canopy_air_coms.mod consts_coms.mod ed_max_dims.mod +heun_driver.o: ed_misc_coms.mod ed_state_vars.mod grid_coms.mod heun_driver.o: hydrology_coms.mod met_driver_coms.mod rk4_coms.mod -heun_driver.o: rk4_driver.mod rk4_stepper.mod soil_coms.mod +heun_driver.o: rk4_driver.mod rk4_stepper.mod soil_coms.mod therm_lib.mod +heun_driver.o: therm_lib8.mod +hybrid_driver.o: consts_coms.mod ed_max_dims.mod ed_misc_coms.mod +hybrid_driver.o: ed_state_vars.mod grid_coms.mod hydrology_coms.mod +hybrid_driver.o: met_driver_coms.mod rk4_coms.mod rk4_driver.mod rk4_stepper.mod +hybrid_driver.o: soil_coms.mod therm_lib8.mod lsm_hyd.o: consts_coms.mod ed_misc_coms.mod ed_node_coms.mod ed_state_vars.mod lsm_hyd.o: grid_coms.mod hydrology_coms.mod hydrology_constants.mod pft_coms.mod lsm_hyd.o: soil_coms.mod therm_lib.mod @@ -474,12 +489,13 @@ mortality.o: consts_coms.mod disturb_coms.mod ed_max_dims.mod ed_misc_coms.mod mortality.o: ed_state_vars.mod pft_coms.mod multiple_scatter.o: canopy_radiation_coms.mod consts_coms.mod ed_max_dims.mod multiple_scatter.o: rk4_coms.mod -phenology_aux.o: allometry.mod consts_coms.mod ed_max_dims.mod ed_misc_coms.mod -phenology_aux.o: ed_state_vars.mod ed_therm_lib.mod grid_coms.mod pft_coms.mod -phenology_aux.o: phenology_coms.mod soil_coms.mod +phenology_aux.o: allometry.mod consts_coms.mod ed_max_dims.mod ed_state_vars.mod +phenology_aux.o: ed_therm_lib.mod grid_coms.mod pft_coms.mod phenology_coms.mod +phenology_aux.o: soil_coms.mod phenology_driv.o: allometry.mod consts_coms.mod decomp_coms.mod ed_max_dims.mod phenology_driv.o: ed_misc_coms.mod ed_state_vars.mod ed_therm_lib.mod -phenology_driv.o: grid_coms.mod pft_coms.mod phenology_coms.mod soil_coms.mod +phenology_driv.o: grid_coms.mod pft_coms.mod phenology_aux.mod +phenology_driv.o: phenology_coms.mod soil_coms.mod photosyn_driv.o: allometry.mod consts_coms.mod ed_max_dims.mod ed_misc_coms.mod photosyn_driv.o: ed_state_vars.mod farq_leuning.mod met_driver_coms.mod photosyn_driv.o: pft_coms.mod phenology_coms.mod physiology_coms.mod @@ -488,15 +504,16 @@ radiate_driver.o: allometry.mod canopy_layer_coms.mod canopy_radiation_coms.mod radiate_driver.o: consts_coms.mod ed_max_dims.mod ed_misc_coms.mod radiate_driver.o: ed_state_vars.mod grid_coms.mod soil_coms.mod reproduction.o: allometry.mod consts_coms.mod decomp_coms.mod ed_max_dims.mod -reproduction.o: ed_state_vars.mod ed_therm_lib.mod fuse_fiss_utils.mod -reproduction.o: grid_coms.mod mem_polygons.mod pft_coms.mod phenology_coms.mod +reproduction.o: ed_misc_coms.mod ed_state_vars.mod ed_therm_lib.mod +reproduction.o: fuse_fiss_utils.mod grid_coms.mod mem_polygons.mod pft_coms.mod +reproduction.o: phenology_aux.mod phenology_coms.mod rk4_derivs.o: canopy_struct_dynamics.mod consts_coms.mod ed_max_dims.mod rk4_derivs.o: ed_misc_coms.mod ed_state_vars.mod grid_coms.mod pft_coms.mod rk4_derivs.o: physiology_coms.mod rk4_coms.mod soil_coms.mod therm_lib8.mod -rk4_driver.o: allometry.mod canopy_air_coms.mod canopy_struct_dynamics.mod -rk4_driver.o: consts_coms.mod disturb_coms.mod ed_misc_coms.mod -rk4_driver.o: ed_state_vars.mod grid_coms.mod met_driver_coms.mod -rk4_driver.o: phenology_coms.mod rk4_coms.mod soil_coms.mod therm_lib.mod +rk4_driver.o: allometry.mod canopy_air_coms.mod consts_coms.mod disturb_coms.mod +rk4_driver.o: ed_misc_coms.mod ed_state_vars.mod grid_coms.mod +rk4_driver.o: met_driver_coms.mod phenology_coms.mod rk4_coms.mod soil_coms.mod +rk4_driver.o: therm_lib.mod rk4_integ_utils.o: canopy_air_coms.mod consts_coms.mod ed_max_dims.mod rk4_integ_utils.o: ed_misc_coms.mod ed_state_vars.mod grid_coms.mod rk4_integ_utils.o: hydrology_coms.mod rk4_coms.mod rk4_stepper.mod soil_coms.mod @@ -513,9 +530,9 @@ structural_growth.o: ed_max_dims.mod ed_misc_coms.mod ed_state_vars.mod structural_growth.o: ed_therm_lib.mod pft_coms.mod twostream_rad.o: canopy_radiation_coms.mod consts_coms.mod ed_max_dims.mod twostream_rad.o: rk4_coms.mod -vegetation_dynamics.o: consts_coms.mod disturb_coms.mod disturbance_utils.mod -vegetation_dynamics.o: ed_misc_coms.mod ed_state_vars.mod fuse_fiss_utils.mod -vegetation_dynamics.o: grid_coms.mod growth_balive.mod mem_polygons.mod +vegetation_dynamics.o: consts_coms.mod disturbance_utils.mod ed_misc_coms.mod +vegetation_dynamics.o: ed_state_vars.mod fuse_fiss_utils.mod grid_coms.mod +vegetation_dynamics.o: growth_balive.mod mem_polygons.mod ed_init.o: consts_coms.mod ed_max_dims.mod ed_misc_coms.mod ed_node_coms.mod ed_init.o: ed_state_vars.mod ed_work_vars.mod grid_coms.mod mem_polygons.mod ed_init.o: phenology_coms.mod phenology_startup.mod rk4_coms.mod soil_coms.mod @@ -528,10 +545,10 @@ ed_nbg_init.o: ed_state_vars.mod fuse_fiss_utils.mod grid_coms.mod pft_coms.mod ed_nbg_init.o: physiology_coms.mod ed_params.o: allometry.mod canopy_air_coms.mod canopy_layer_coms.mod ed_params.o: canopy_radiation_coms.mod consts_coms.mod decomp_coms.mod -ed_params.o: disturb_coms.mod ed_max_dims.mod ed_misc_coms.mod -ed_params.o: fusion_fission_coms.mod grid_coms.mod hydrology_coms.mod -ed_params.o: met_driver_coms.mod pft_coms.mod phenology_coms.mod -ed_params.o: physiology_coms.mod rk4_coms.mod soil_coms.mod +ed_params.o: detailed_coms.mod disturb_coms.mod ed_max_dims.mod ed_misc_coms.mod +ed_params.o: ed_therm_lib.mod fusion_fission_coms.mod grid_coms.mod +ed_params.o: hydrology_coms.mod met_driver_coms.mod pft_coms.mod +ed_params.o: phenology_coms.mod physiology_coms.mod rk4_coms.mod soil_coms.mod ed_type_init.o: allometry.mod canopy_air_coms.mod consts_coms.mod ed_type_init.o: ed_max_dims.mod ed_misc_coms.mod ed_state_vars.mod ed_type_init.o: ed_therm_lib.mod grid_coms.mod pft_coms.mod phenology_coms.mod @@ -541,31 +558,30 @@ init_hydro_sites.o: grid_coms.mod mem_polygons.mod soil_coms.mod landuse_init.o: consts_coms.mod disturb_coms.mod ed_max_dims.mod landuse_init.o: ed_misc_coms.mod ed_state_vars.mod grid_coms.mod phenology_startup.o: ed_max_dims.mod ed_misc_coms.mod ed_state_vars.mod -phenology_startup.o: grid_coms.mod phenology_coms.mod +phenology_startup.o: grid_coms.mod phenology_aux.mod phenology_coms.mod average_utils.o: allometry.mod canopy_radiation_coms.mod consts_coms.mod average_utils.o: ed_max_dims.mod ed_misc_coms.mod ed_state_vars.mod average_utils.o: grid_coms.mod pft_coms.mod therm_lib.mod -ed_init_full_history.o: allometry.mod c34constants.mod consts_coms.mod -ed_init_full_history.o: ed_max_dims.mod ed_misc_coms.mod ed_node_coms.mod -ed_init_full_history.o: ed_state_vars.mod fusion_fission_coms.mod grid_coms.mod -ed_init_full_history.o: hdf5_coms.mod phenology_startup.mod -ed_init_full_history.o: soil_coms.mod therm_lib.mod +ed_init_full_history.o: allometry.mod ed_max_dims.mod ed_misc_coms.mod +ed_init_full_history.o: ed_node_coms.mod ed_state_vars.mod +ed_init_full_history.o: fusion_fission_coms.mod grid_coms.mod +ed_init_full_history.o: hdf5_coms.mod phenology_startup.mod soil_coms.mod ed_load_namelist.o: canopy_air_coms.mod canopy_layer_coms.mod ed_load_namelist.o: canopy_radiation_coms.mod consts_coms.mod decomp_coms.mod -ed_load_namelist.o: disturb_coms.mod ed_max_dims.mod ed_misc_coms.mod -ed_load_namelist.o: ed_para_coms.mod ename_coms.mod grid_coms.mod -ed_load_namelist.o: mem_polygons.mod met_driver_coms.mod optimiz_coms.mod -ed_load_namelist.o: pft_coms.mod phenology_coms.mod physiology_coms.mod -ed_load_namelist.o: rk4_coms.mod soil_coms.mod +ed_load_namelist.o: detailed_coms.mod disturb_coms.mod ed_max_dims.mod +ed_load_namelist.o: ed_misc_coms.mod ed_para_coms.mod ename_coms.mod +ed_load_namelist.o: grid_coms.mod mem_polygons.mod met_driver_coms.mod +ed_load_namelist.o: optimiz_coms.mod pft_coms.mod phenology_coms.mod +ed_load_namelist.o: physiology_coms.mod rk4_coms.mod soil_coms.mod ed_opspec.o: canopy_air_coms.mod canopy_layer_coms.mod canopy_radiation_coms.mod -ed_opspec.o: consts_coms.mod decomp_coms.mod disturb_coms.mod ed_max_dims.mod -ed_opspec.o: ed_misc_coms.mod ed_para_coms.mod grid_coms.mod mem_polygons.mod -ed_opspec.o: met_driver_coms.mod pft_coms.mod phenology_coms.mod -ed_opspec.o: physiology_coms.mod rk4_coms.mod soil_coms.mod +ed_opspec.o: consts_coms.mod decomp_coms.mod detailed_coms.mod disturb_coms.mod +ed_opspec.o: ed_max_dims.mod ed_misc_coms.mod ed_para_coms.mod grid_coms.mod +ed_opspec.o: mem_polygons.mod met_driver_coms.mod pft_coms.mod +ed_opspec.o: phenology_coms.mod physiology_coms.mod rk4_coms.mod soil_coms.mod ed_print.o: ed_max_dims.mod ed_misc_coms.mod ed_node_coms.mod ed_state_vars.mod ed_print.o: ed_var_tables.mod -ed_read_ed10_20_history.o: allometry.mod consts_coms.mod disturb_coms.mod -ed_read_ed10_20_history.o: ed_max_dims.mod ed_misc_coms.mod ed_state_vars.mod +ed_read_ed10_20_history.o: allometry.mod consts_coms.mod ed_max_dims.mod +ed_read_ed10_20_history.o: ed_misc_coms.mod ed_state_vars.mod ed_read_ed10_20_history.o: fuse_fiss_utils.mod grid_coms.mod mem_polygons.mod ed_read_ed10_20_history.o: pft_coms.mod ed_read_ed21_history.o: allometry.mod consts_coms.mod disturb_coms.mod @@ -577,12 +593,11 @@ ed_xml_config.o: ed_max_dims.mod ed_misc_coms.mod fusion_fission_coms.mod ed_xml_config.o: grid_coms.mod hydrology_coms.mod met_driver_coms.mod ed_xml_config.o: pft_coms.mod phenology_coms.mod physiology_coms.mod ed_xml_config.o: rk4_coms.mod soil_coms.mod -edio.o: c34constants.mod consts_coms.mod ed_max_dims.mod ed_misc_coms.mod -edio.o: ed_node_coms.mod ed_state_vars.mod grid_coms.mod pft_coms.mod -edio.o: soil_coms.mod therm_lib.mod -h5_output.o: an_header.mod c34constants.mod ed_max_dims.mod ed_misc_coms.mod -h5_output.o: ed_node_coms.mod ed_state_vars.mod ed_var_tables.mod -h5_output.o: fusion_fission_coms.mod grid_coms.mod hdf5_coms.mod +edio.o: consts_coms.mod ed_max_dims.mod ed_misc_coms.mod ed_node_coms.mod +edio.o: ed_state_vars.mod grid_coms.mod pft_coms.mod soil_coms.mod therm_lib.mod +h5_output.o: an_header.mod ed_max_dims.mod ed_misc_coms.mod ed_node_coms.mod +h5_output.o: ed_state_vars.mod ed_var_tables.mod fusion_fission_coms.mod +h5_output.o: grid_coms.mod hdf5_coms.mod leaf_database.o: grid_coms.mod hdf5_utils.mod soil_coms.mod canopy_air_coms.o: consts_coms.mod therm_lib.mod therm_lib8.mod canopy_radiation_coms.o: ed_max_dims.mod @@ -594,10 +609,10 @@ ed_mem_alloc.o: ed_max_dims.mod ed_mem_grid_dim_defs.mod ed_node_coms.mod ed_mem_alloc.o: ed_state_vars.mod ed_work_vars.mod grid_coms.mod ed_mem_alloc.o: mem_polygons.mod ed_misc_coms.o: ed_max_dims.mod -ed_state_vars.o: c34constants.mod disturb_coms.mod ed_max_dims.mod -ed_state_vars.o: ed_misc_coms.mod ed_node_coms.mod ed_var_tables.mod -ed_state_vars.o: fusion_fission_coms.mod grid_coms.mod met_driver_coms.mod -ed_state_vars.o: phenology_coms.mod soil_coms.mod +ed_state_vars.o: disturb_coms.mod ed_max_dims.mod ed_misc_coms.mod +ed_state_vars.o: ed_node_coms.mod ed_var_tables.mod fusion_fission_coms.mod +ed_state_vars.o: grid_coms.mod met_driver_coms.mod phenology_coms.mod +ed_state_vars.o: soil_coms.mod ed_var_tables.o: ed_max_dims.mod ed_work_vars.o: ed_max_dims.mod ename_coms.o: ed_max_dims.mod @@ -614,12 +629,13 @@ rk4_coms.o: consts_coms.mod ed_max_dims.mod ed_misc_coms.mod grid_coms.mod rk4_coms.o: soil_coms.mod therm_lib8.mod soil_coms.o: ed_max_dims.mod grid_coms.mod leaf_coms.mod ed_mpass_init.o: canopy_air_coms.mod canopy_layer_coms.mod -ed_mpass_init.o: canopy_radiation_coms.mod decomp_coms.mod disturb_coms.mod -ed_mpass_init.o: ed_max_dims.mod ed_misc_coms.mod ed_node_coms.mod -ed_mpass_init.o: ed_para_coms.mod ed_state_vars.mod ed_work_vars.mod -ed_mpass_init.o: grid_coms.mod mem_polygons.mod met_driver_coms.mod -ed_mpass_init.o: optimiz_coms.mod pft_coms.mod phenology_coms.mod -ed_mpass_init.o: physiology_coms.mod rk4_coms.mod soil_coms.mod +ed_mpass_init.o: canopy_radiation_coms.mod decomp_coms.mod detailed_coms.mod +ed_mpass_init.o: disturb_coms.mod ed_max_dims.mod ed_misc_coms.mod +ed_mpass_init.o: ed_node_coms.mod ed_para_coms.mod ed_state_vars.mod +ed_mpass_init.o: ed_work_vars.mod grid_coms.mod mem_polygons.mod +ed_mpass_init.o: met_driver_coms.mod optimiz_coms.mod pft_coms.mod +ed_mpass_init.o: phenology_coms.mod physiology_coms.mod rk4_coms.mod +ed_mpass_init.o: soil_coms.mod ed_node_coms.o: ed_max_dims.mod ed_para_coms.o: ed_max_dims.mod ed_para_init.o: ed_max_dims.mod ed_misc_coms.mod ed_node_coms.mod @@ -629,6 +645,7 @@ allometry.o: consts_coms.mod ed_misc_coms.mod grid_coms.mod pft_coms.mod allometry.o: rk4_coms.mod soil_coms.mod budget_utils.o: consts_coms.mod ed_max_dims.mod ed_misc_coms.mod budget_utils.o: ed_state_vars.mod grid_coms.mod rk4_coms.mod soil_coms.mod +budget_utils.o: therm_lib.mod dateutils.o: consts_coms.mod ed_filelist.o: ed_max_dims.mod ed_grid.o: consts_coms.mod ed_max_dims.mod ed_node_coms.mod grid_coms.mod @@ -637,11 +654,11 @@ ed_therm_lib.o: ed_max_dims.mod ed_misc_coms.mod ed_state_vars.mod grid_coms.mod ed_therm_lib.o: pft_coms.mod rk4_coms.mod soil_coms.mod therm_lib.mod ed_therm_lib.o: therm_lib8.mod fatal_error.o: ed_node_coms.mod -fuse_fiss_utils.o: allometry.mod canopy_layer_coms.mod consts_coms.mod -fuse_fiss_utils.o: decomp_coms.mod disturb_coms.mod ed_max_dims.mod -fuse_fiss_utils.o: ed_misc_coms.mod ed_node_coms.mod ed_state_vars.mod -fuse_fiss_utils.o: fusion_fission_coms.mod grid_coms.mod mem_polygons.mod -fuse_fiss_utils.o: pft_coms.mod soil_coms.mod therm_lib.mod +fuse_fiss_utils.o: allometry.mod canopy_layer_coms.mod decomp_coms.mod +fuse_fiss_utils.o: disturb_coms.mod ed_max_dims.mod ed_misc_coms.mod +fuse_fiss_utils.o: ed_node_coms.mod ed_state_vars.mod fusion_fission_coms.mod +fuse_fiss_utils.o: grid_coms.mod mem_polygons.mod pft_coms.mod soil_coms.mod +fuse_fiss_utils.o: therm_lib.mod great_circle.o: consts_coms.mod hdf5_utils.o: hdf5_coms.mod invmondays.o: ed_misc_coms.mod @@ -657,11 +674,9 @@ update_derived_props.o: allometry.mod canopy_air_coms.mod consts_coms.mod update_derived_props.o: ed_misc_coms.mod ed_state_vars.mod ed_therm_lib.mod update_derived_props.o: fuse_fiss_utils.mod grid_coms.mod soil_coms.mod update_derived_props.o: therm_lib.mod -adv_message_mod.mod: adv_message_mod.o advect_kit.mod: mod_advect_kit.o allometry.mod: allometry.o an_header.mod: an_header.o -boundary_mod.mod: boundary_mod.o c34constants.mod: c34constants.o canopy_air_coms.mod: canopy_air_coms.o canopy_layer_coms.mod: canopy_layer_coms.o @@ -672,6 +687,7 @@ consts_coms.mod: consts_coms.o conv_coms.mod: conv_coms.o cyclic_mod.mod: cyclic_mod.o decomp_coms.mod: decomp_coms.o +detailed_coms.mod: detailed_coms.o disturb_coms.mod: disturb_coms.o disturbance_utils.mod: disturbance.o domain_decomp.mod: domain_decomp.o @@ -687,7 +703,6 @@ ed_var_tables.mod: ed_var_tables.o ed_work_vars.mod: ed_work_vars.o emission_source_map.mod: emission_source_map.o ename_coms.mod: ename_coms.o -error_mod.mod: error_mod.o extras.mod: extra.o farq_leuning.mod: farq_leuning.o fuse_fiss_utils.mod: fuse_fiss_utils.o @@ -695,7 +710,6 @@ fusion_fission_coms.mod: fusion_fission_coms.o grell_coms.mod: grell_coms.o grid_coms.mod: grid_coms.o grid_dims.mod: grid_dims.o -grid_mod.mod: grid_mod.o grid_struct.mod: grid_struct.o growth_balive.mod: growth_balive.o harr_coms.mod: harr_coms.o @@ -703,7 +717,6 @@ hdf5_coms.mod: hdf5_coms.o hdf5_utils.mod: hdf5_utils.o hydrology_coms.mod: hydrology_coms.o hydrology_constants.mod: hydrology_constants.o -init_advect.mod: init_advect.o io_params.mod: io_params.o isan_coms.mod: isan_coms.o ke_coms.mod: ke_coms.o @@ -714,7 +727,6 @@ libxml2f90_module.mod: libxml2f90.f90_pp.o libxml2f90_strings_module.mod: libxml2f90.f90_pp.o ll_module.mod: libxml2f90.f90_pp.o machine_arq.mod: machine_arq.o -mapmod.mod: MapMod.o mem_aerad.mod: mem_aerad.o mem_all.mod: mem_all.o mem_basic.mod: mem_basic.o @@ -735,6 +747,7 @@ mem_mass.mod: mem_mass.o mem_mclat.mod: mem_mclat.o mem_micro.mod: mem_micro.o mem_mksfc.mod: mem_mksfc.o +mem_mnt_advec.mod: mem_mnt_advec.o mem_nestb.mod: mem_nestb.o mem_oda.mod: mem_oda.o mem_opt.mod: mem_opt_scratch.o @@ -762,18 +775,17 @@ micphys.mod: micphys.o micro_coms.mod: micro_coms.o mod_ghostblock.mod: mod_GhostBlock.o mod_ghostblockpartition.mod: mod_GhostBlockPartition.o -monotonic_adv.mod: radvc_mnt.o mortality.mod: mortality.o node_mod.mod: node_mod.o obs_input.mod: obs_input.o optimiz_coms.mod: optimiz_coms.o ozone_const.mod: mod_ozone.o pft_coms.mod: pft_coms.o +phenology_aux.mod: phenology_aux.o phenology_coms.mod: phenology_coms.o phenology_startup.mod: phenology_startup.o physiology_coms.mod: physiology_coms.o plume_utils.mod: plumerise_vector.o -processor_mod.mod: processor_mod.o rad_carma.mod: rad_carma.o rconstants.mod: rconstants.o ref_sounding.mod: ref_sounding.o diff --git a/BRAMS/build/bin/include.mk.opt.odyssey b/BRAMS/build/bin/include.mk.opt.odyssey index 14df61daa..c12b52bb1 100644 --- a/BRAMS/build/bin/include.mk.opt.odyssey +++ b/BRAMS/build/bin/include.mk.opt.odyssey @@ -60,7 +60,7 @@ HDF4_LIBS=-lmfhdf -ldf -lz -ljpeg # library files. Make sure you include the zlib.a location too. USE_HDF5=1 HDF5_INCS= -HDF5_LIBS=-lhdf5 -lm -lhdf5_fortran -lhdf5 -lhdf5_hl -lz +HDF5_LIBS=-lhdf5_fortran -lhdf5 -lhdf5_hl -lz -l, #HDF5_INCS= #HDF5_LIBS=-L/n/sw/hdf5-1.8.5_intel-11.1.072/ -lhdf5 -lm -lhdf5_fortran -lhdf5 -lhdf5_hl -lz # MPI_Wtime. --------------------------------------------------- @@ -253,25 +253,25 @@ KIND_COMP=E #------------------------------------------------------------------------------------------# ifeq ($(KIND_COMP),A) USE_INTERF=0 - F_OPTS= -FR -O0 -recursive -Vaxlib -check all -g -fpe0 -ftz -gen-interfaces \ + F_OPTS= -FR -O0 -recursive -Vaxlib -check all -g -fpe0 -no-ftz -gen-interfaces \ -warn interfaces -debug extended -debug inline_debug_info \ -debug-parameters all -traceback -ftrapuv -fp-stack-check -implicitnone \ - -openmp -assume byterecl + -openmp -assume byterecl -e90 C_OPTS= -O0 -DLITTLE -g -traceback -debug extended - LOADER_OPTS= -FR -O0 -Vaxlib -check all -g -fpe0 -ftz -gen-interfaces \ + LOADER_OPTS= -FR -O0 -Vaxlib -check all -g -fpe0 -no-ftz -gen-interfaces \ -warn interfaces -debug extended -debug inline_debug_info \ -debug-parameters all -traceback -ftrapuv -fp-stack-check -implicitnone \ - -openmp -assume byterecl + -openmp -assume byterecl -e90 C_LOADER_OPTS=-v -g -traceback #---------------------------------------------------------------------------------------# endif ifeq ($(KIND_COMP),B) USE_INTERF=1 - F_OPTS= -FR -O0 -recursive -Vaxlib -check all -g -fpe0 -ftz -debug extended \ + F_OPTS= -FR -O0 -recursive -Vaxlib -check all -g -fpe0 -no-ftz -debug extended \ -debug inline_debug_info -debug-parameters all -traceback -ftrapuv \ -fp-stack-check -implicitnone -openmp -assume byterecl C_OPTS= -O0 -DLITTLE -g -traceback -debug extended - LOADER_OPTS= -FR -O0 -Vaxlib -check all -g -fpe0 -ftz -debug extended \ + LOADER_OPTS= -FR -O0 -Vaxlib -check all -g -fpe0 -no-ftz -debug extended \ -debug inline_debug_info -debug-parameters all -traceback -ftrapuv \ -fp-stack-check -implicitnone -openmp -assume byterecl C_LOADER_OPTS=-v -g -traceback @@ -279,11 +279,11 @@ ifeq ($(KIND_COMP),B) endif ifeq ($(KIND_COMP),C) USE_INTERF=1 - F_OPTS= -FR -O2 -recursive -Vaxlib -check all -g -fpe0 -ftz -debug extended \ + F_OPTS= -FR -O2 -recursive -Vaxlib -check all -g -fpe0 -no-ftz -debug extended \ -debug inline_debug_info -debug-parameters all -traceback -ftrapuv \ -fp-stack-check -implicitnone -openmp -assume byterecl C_OPTS= -O2 -DLITTLE -g -traceback -debug extended - LOADER_OPTS= -FR -O2 -Vaxlib -check all -g -fpe0 -ftz -debug extended \ + LOADER_OPTS= -FR -O2 -Vaxlib -check all -g -fpe0 -no-ftz -debug extended \ -debug inline_debug_info -debug-parameters all -traceback -ftrapuv \ -fp-stack-check -implicitnone -openmp -assume byterecl C_LOADER_OPTS=-v -g -traceback @@ -291,19 +291,20 @@ ifeq ($(KIND_COMP),C) endif ifeq ($(KIND_COMP),D) USE_INTERF=1 - F_OPTS= -FR -O2 -recursive -Vaxlib -check all -fpe0 -ftz -traceback -ftrapuv \ + F_OPTS= -FR -O2 -recursive -Vaxlib -check all -fpe0 -no-ftz -traceback -ftrapuv \ -fp-stack-check -implicitnone -openmp -assume byterecl C_OPTS= -O2 -DLITTLE -traceback - LOADER_OPTS= -FR -O2 -Vaxlib -check all -fpe0 -ftz -traceback -ftrapuv -fp-stack-check \ + LOADER_OPTS= -FR -O2 -Vaxlib -check all -fpe0 -no-ftz -traceback -ftrapuv -fp-stack-check \ -implicitnone -openmp -assume byterecl C_LOADER_OPTS=-v -traceback #---------------------------------------------------------------------------------------# endif ifeq ($(KIND_COMP),E) USE_INTERF=1 - F_OPTS= -FR -O3 -recursive -Vaxlib -traceback -axP -assume byterecl + F_OPTS= -FR -O3 -recursive -traceback -assume byterecl -static -axP \ + -openmp C_OPTS= -O3 -DLITTLE -traceback - LOADER_OPTS= -FR -O3 -Vaxlib -traceback -axP -assume byterecl + LOADER_OPTS= -FR -O3 -traceback -assume byterecl -unroll -axP -openmp C_LOADER_OPTS=-v -traceback #---------------------------------------------------------------------------------------# endif diff --git a/BRAMS/build/bin/objects.mk b/BRAMS/build/bin/objects.mk index 8eb3de73c..6463edfb5 100644 --- a/BRAMS/build/bin/objects.mk +++ b/BRAMS/build/bin/objects.mk @@ -111,6 +111,7 @@ OBJ_MODEL = \ mem_mass.o \ mem_mclat.o \ mem_micro.o \ + mem_mnt_advec.o \ mem_mksfc.o \ mem_nestb.o \ mem_oda.o \ @@ -150,12 +151,15 @@ OBJ_MODEL = \ mksfc_sfc.o \ mksfc_sst.o \ mksfc_top.o \ + mnt_advec_aux.o \ + mnt_advec_main.o \ mod_advect_kit.o \ mod_GhostBlock.o \ mod_GhostBlockPartition.o \ mod_ozone.o \ model.o \ modsched.o \ + mpass_advec.o \ mpass_cyclic.o \ mpass_dtl.o \ mpass_feed.o \ @@ -360,5 +364,8 @@ OBJ_MODEL = \ structural_growth.o \ twostream_rad.o \ update_derived_props.o \ - vegetation_dynamics.o + vegetation_dynamics.o \ + detailed_coms.o \ + bdf2_solver.o \ + hybrid_driver.o diff --git a/BRAMS/build/bin/paths.mk b/BRAMS/build/bin/paths.mk index 44843ef7a..465ad58d6 100644 --- a/BRAMS/build/bin/paths.mk +++ b/BRAMS/build/bin/paths.mk @@ -36,6 +36,7 @@ MASS=$(BRAMS_ROOT)/src/mass MEMORY=$(BRAMS_ROOT)/src/memory MICRO=$(BRAMS_ROOT)/src/micro MKSFC=$(BRAMS_ROOT)/src/mksfc +MNTADVEC=$(BRAMS_ROOT)/src/mnt_advec MPI=$(BRAMS_ROOT)/src/mpi NESTING=$(BRAMS_ROOT)/src/nesting OLDGRELL=$(BRAMS_ROOT)/src/oldgrell diff --git a/BRAMS/build/bin/rules.mk b/BRAMS/build/bin/rules.mk index 7c78543c3..7a51d3614 100644 --- a/BRAMS/build/bin/rules.mk +++ b/BRAMS/build/bin/rules.mk @@ -514,6 +514,11 @@ mem_mksfc.o : $(MKSFC)/mem_mksfc.f90 $(F90_COMMAND) $({'source_file'} = $filename; + $self->{'filepath'} = $path; + $self->{'includes'} = {}; + $self->{'uses'} = {}; + $self->{'modules'} = {}; + bless $self; +} + +sub find_includes { + my $self = shift; + my $file = $self->{'filepath'}; + my($after, $filepath, $ref, $included, $use, $modname); + local(*FILE); + local($_); + + if (-f $file) { + open(FILE, $file) || warn "Can't open $file: $!\n"; + } elsif (-f "RCS/$file,v" || -f "$file,v" ) { + system("co $file"); + open(FILE, $file) || warn "Can't open $file: $!\n"; + $main::rcs{$file} = 1; + } else { + return; + } + while () { + $included = ""; + $use = ""; + # look for Fortran style includes + if (/^\s*include\s*['"]([^"']*)["']/i) { + $included = $1; + $after = $'; + # C preprocessor style includes + } elsif (/^#\s*include\s*["<]([^">]*)[">]/) { + $included = $1; + $after = $'; + # Fortran 90 "use" + } elsif (/^\s*use\s+(\w+)/i) { + $use = $1; +# Make the module name lowercase except for SGI & HP. +# May be compiler dependent!! + if ($main::sgi || $main::hp) { + $use = uc($use); + } else { + $use = lc($use); + } + $self->{'uses'}{$use} = 1; + # Fortran 90 module + } elsif (/^\s*module\s+(\w+)/i) { + $modname = $1; + if ($main::sgi || $main::hp) { + $modname = uc($modname); + } else { + $modname = lc($modname); + } + unless (lc($modname) eq "procedure") { + $main::mod_files{$modname} = $file; + $self->{'modules'}{$modname} = 1; + } + } + if ($included) { + if ( $inc_files{$included} ) { + $filepath = $inc_files{$included}{'filepath'}; + } else { + $filepath = &main::findfile($included); + $ref = new source_file($included, $filepath); + $inc_files{$included} = $ref; +# Search included file for includes + $ref->find_includes(); + } + if ( $filepath ) { + $self->{'includes'}{$included} = 1; + } else { + if ($after !~ /bogus/i) { + warn "Can't find file: $included\n"; + } + } + } + } + close FILE; +} + +sub print_includes { + my $self = shift; + my $target = shift; + my $len_sum = shift; + my($file, $ref); + my %printed = (); + + foreach $file (keys %{$self->{'includes'}}) { + next if $printed{$file}; + $ref = $inc_files{$file}; + my $len = length($ref->{'filepath'}) + 1; + if (($len_sum + $len > 80) && + (length($target) + 1 < $len_sum)) { + print "\n$target:"; + $len_sum = length($target) + 1; + } + print " " . $ref->{'filepath'}; + $printed{$file} = 1; + $len_sum += $len; + $len_sum = $ref->print_includes($target, $len_sum); + } + $len_sum; +} + +# return list of modules used by included files +sub inc_mods { + my $self = shift; + my($file, $ref, $mod, @sub_list); + my @list = (); + my %printed = (); + + foreach $mod (keys %{$self->{'uses'}}) { + push(@list, $mod); + } + + foreach $file (keys %{$self->{'includes'}}) { + next if $printed{$file}; + $ref = $inc_files{$file}; + $printed{$file} = 1; + @sub_list = $ref->inc_mods(); + @list = (@list, @sub_list); + } + @list; +} + +# filenames containing the list of modules used by file and all its includes +sub find_mods { + my $self = shift; + my($ref, $modname, $file, @list, $base); + my @module_files = (); + my @mod_list = (); + my @tmp_list = (); + +# find modules used by include files + if (%{$self->{'includes'}}) { + foreach $file (keys %{$self->{'includes'}}) { + $ref = $inc_files{$file}; + @list = $ref->inc_mods(); + @tmp_list = @mod_list; + @mod_list = (@tmp_list, @list); + } + } + +# add them to the uses list (hash ensures uniqueness) + foreach $modname (@mod_list) { + $self->{'uses'}{$modname} = 1; + } + +# now find the filename that contains the module information + foreach $modname (keys %{$self->{'uses'}}) { + if ($main::cray || $main::parasoft) { + if ($file = $main::mod_files{$modname}) { + $base = &main::basename($file, @main::suffixes); + $file = $base . "." . $main::obj_ext; + push(@module_files, $file); + } else { + warn "Don't know where module $modname lives.\n"; + } + } else { + $modname .= "." . $main::mod_ext; + push(@module_files, $modname); + } + } + sort(@module_files); +} + +sub print { + my $self = shift; + my $source = $self->{'source_file'}; + my $compile_string = "\t" . '$(CFT) $(FFLAGS) -c'; + my($base, $object, $modname, $flag, $target, $ftarget); + + $base = &main::basename($source, @main::suffixes); + $target = $base . "." . $main::obj_ext; + if ($main::stupid) { + $ftarget = $base . "." . $main::ext; + } + + if ($main::cray) { + $flag = " -p "; + } elsif ($main::parasoft) { + $flag = " -module "; + } + +# print out "include" dependencies + if (%{$self->{'includes'}}) { + my $len_sum = length($target) + 1; + if ($main::add_ext) { + $target .= " $base.$main::add_ext"; + $len_sum += length($base) + length($main::add_ext) + 2; + } + print "$target:"; + $self->print_includes($target, $len_sum); + print "\n"; + if ($main::stupid) { + $len_sum = length($ftarget) + 1; + print "$ftarget:"; + $self->print_includes($ftarget, $len_sum); + print "\n"; + } + } + +# clean out "use" of modules in own file + foreach $mod ( keys %{$self->{'uses'}} ) { + if ( ${$self->{'modules'}}{$mod} ) { + delete ${$self->{'uses'}}{$mod}; + } + } + +# print out "use" dependencies + if (%{$self->{'uses'}} || %{$self->{'includes'}}) { + @module_files = $self->find_mods(); + my $len_sum = length($target) + 1; + print "$target:"; + foreach $file (@module_files) { + my $len = length($file) + 1; + if (($len_sum + $len > 80) && + (length($target) + 1 < $len_sum)) { + print "\n$target:"; + $len_sum = length($target) + 1; + } + $len_sum += $len; + print " " . $file; + } + if ($main::need_f) { + my $len = length($ftarget) + 1; + if (($len_sum + $len > 80) && + (length($target) + 1 < $len_sum)) { + print "\n$target:"; + $len_sum = length($target) + 1; + } + print " " . $ftarget; + } + print "\n"; +# extra Cray / Parasoft stuff + if ($main::cray || $main::parasoft) { + print $compile_string; + foreach $file (@module_files) { + print $flag . $file; + } + if ($main::stupid) { + print " " . $ftarget . "\n"; + } else { + print " " . $source . "\n"; + } + } + } +} + + +# Start of main program +package main; + +if ($] < 5.000) { die "Need perl 5.000 or newer\n"; } +use File::Basename; +use Getopt::Long; +@suffixes = qw( .c .C .cc .cxx .cpp .f .F .fcm .FCM .f90 .F90 .for); + +GetOptions("s", "e=s", "f=s", "I=s@", "m=s", "c", "p", "g", "h", "o=s", "a=s") + || die "problem in GetOptions"; + +# For compilers that don't invoke cpp for you +if ($opt_s) { + $stupid = 1; +} +if ($opt_e) { + $ext = $opt_e; +} else { + $ext = "f"; +} + +# list of directories to search, starting with current directory +if (@opt_I) { + @incdirs = @opt_I; +} elsif (@opt_i) { + @incdirs = @opt_i; +} + +if ($opt_f) { + $mf = $opt_f; +} elsif (-f "makefile") { + $mf = 'makefile'; +} else { + $mf = 'Makefile'; +} +if ( !(-f $mf)) { + system "touch $mf"; +} + +# extension used for compiler's private module information +if ($opt_m) { + $mod_ext = $opt_m; +} else { + $mod_ext = 'mod'; +} + +if ($opt_c) { + $cray = 1; +} + +if ($opt_p) { + $parasoft = 1; +} + +if ($opt_g) { + $sgi = 1; + $mod_ext = 'kmo'; +} + +if ($opt_h) { + $hp = 1; +} + +# need to add some more dependencies so the .f file gets created +if ($stupid && ($cray || $parasoft)) { + $need_f = 1; +} + +if ($opt_c && $opt_p) { + die "Doesn't make sense to have both Cray and Parasoft options!"; +} + +# object file extension +if ($opt_o) { + $obj_ext = $opt_o; +} else { + $obj_ext = 'o'; +} + +# extension for additional targets (like .prj) +if ($opt_a) { + $add_ext = $opt_a; +} + +$mystring = '# DO NOT DELETE THIS LINE - used by make depend'; + + +# Search for the includes in all the files +foreach $file (@ARGV) { + $sources{$file} = new source_file($file, $file); + $sources{$file}->find_includes(); +} + +# Create new Makefile with new dependencies. + +open(MFILE, $mf) || die "can't read Makefile $mf: $!\n"; +open(NMFILE, "> Makefile.new") || die "can't write Makefile.new: $!\n"; +select(NMFILE); + +while () { + if (!/$mystring/) { + print; + } else { + last; + } +} + +print $mystring, "\n"; + +# Now print out include and use dependencies in sorted order. +foreach $target (sort keys(%sources)) { + $sources{$target}->print(); +} + +# print out module dependencies +if ( !( $cray || $parasoft) ) { + foreach $modname (sort keys(%mod_files)) { + ($name, $path, $suffix) = + &fileparse($sources{$mod_files{$modname}}->{'filepath'}, @suffixes); + $object = $name . "." . $obj_ext; +## $object = $path . "/" . $name . "." . $obj_ext; + print "$modname.$mod_ext: $object\n"; + } +} + +# Sort out the Makefiles + +rename($mf, "$mf.old") || warn "can't overwrite $mf.old: $!\n"; +rename('Makefile.new', $mf) || + warn "can't move Makefile.new to $mf: $!\n"; + +# Delete those RCS files we checked out +foreach $file (keys %rcs) { + unlink($file); +} + +# +# End of main +# + +sub findfile { +# Let's see if we can find the included file. Look in current +# directory first, then in directories from -I arguments. Finally, +# look for RCS files in current directory. + my $file = shift; + my($found, $i, $filepath); + + $found = 0; + + if ( -f $file ) { + $found = 1; + $file =~ s#^\./##; # convert ./foo.h to foo.h + return $file; + } + foreach $i (0 .. $#incdirs) { + $filepath = $incdirs[$i]."/".$file; + if ( -f $filepath ) { + $found = 1; + $filepath =~ s#^\./##; # convert ./foo.h to foo.h + return $filepath; + } + } +#see if it is a checked-in RCS file + if (-f "RCS/$file,v" || -f "$file,v" ) { + $found = 1; + system("co $file"); + $filepath = $file; + $rcs{$file} = 1; + } + if ( ! $found ) { + $filepath = ""; + } + $filepath; +} diff --git a/BRAMS/run/RAMSIN b/BRAMS/run/RAMSIN index 044bbd700..5533ea2cf 100644 --- a/BRAMS/run/RAMSIN +++ b/BRAMS/run/RAMSIN @@ -1055,6 +1055,15 @@ $MODEL_OPTIONS + !---------------------------------------------------------------------------------------! + ! IADVEC -- 1 - Original advection scheme ! + ! 2 - Monotic advection scheme, as in Freitas et al. (2001, in press JAMES). ! + !---------------------------------------------------------------------------------------! + IADVEC = 1, + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! ! IEXEV -- Exner function tendency. ! ! 1 -- original BRAMS. This ignores advection, compression and heating. Not ! @@ -2057,12 +2066,31 @@ $ED2_INFO + + !---------------------------------------------------------------------------------------! + ! IBIGLEAF -- Do you want to run ED as a 'big leaf' model? ! + ! 0. No, use the standard size- and age-structure (Moorcroft et al. 2001) ! + ! This is the recommended method for most applications. ! + ! 1. 'big leaf' ED: this will have no horizontal or vertical hetero- ! + ! geneities; 1 patch per PFT and 1 cohort per patch; no vertical ! + ! growth, recruits will 'appear' instantaneously at maximum height. ! + ! ! + ! N.B. if you set IBIGLEAF to 1, you MUST turn off the crown model (CROWN_MOD = 0) ! + !---------------------------------------------------------------------------------------! + IBIGLEAF = 0, + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! ! INTEGRATION_SCHEME -- The biophysics integration scheme. ! ! 0. Euler step. The fastest, but it doesn't estimate ! ! errors. ! ! 1. Fourth-order Runge-Kutta method. ED-2.1 default method ! ! 2. Heun's method (a second-order Runge-Kutta). ! + ! 3. Hybrid Stepping (BDF2 implicit step for the canopy air and ! + ! leaf temp, forward Euler for else, under development). ! !---------------------------------------------------------------------------------------! INTEGRATION_SCHEME = 1, !---------------------------------------------------------------------------------------! @@ -2205,8 +2233,12 @@ $ED2_INFO ! to the same polygon, even if they are in different sites. They ! ! can't go outside their original polygon, though. This is the ! ! same as option 1 if there is only one site per polygon. ! + ! 3. Similar to 2, but recruits will only be formed if their phenology ! + ! status would be "leaves fully flushed". This only matters for ! + ! drought deciduous plants. This option is for testing purposes ! + ! only, think 50 times before using it... ! !---------------------------------------------------------------------------------------! - REPRO_SCHEME = 1, + REPRO_SCHEME = 2, !---------------------------------------------------------------------------------------! @@ -2432,24 +2464,28 @@ $ED2_INFO !---------------------------------------------------------------------------------------! ! The following parameters adjust the fire disturbance in the model. ! - ! INCLUDE_FIRE -- Which threshold to use for fires. ! - ! 0. No fires; ! - ! 1. (deprecated) Fire will be triggered with enough biomass and ! - ! integrated ground water depth less than a threshold. Based on ! - ! ED-1, the threshold assumes that the soil is 1 m, so deeper ! - ! soils will need to be much drier to allow fires to happen and ! - ! often will never allow fires. ! - ! 2. Fire will be triggered with enough biomass and the total soil ! - ! water at the top 75 cm falls below a threshold. ! - ! SM_FIRE -- This is used only when INCLUDE_FIRE = 2. The sign here matters. ! - ! >= 0. - Minimum relative soil moisture above dry air of the top 75cm ! - ! that will prevent fires to happen. ! - ! < 0. - Minimum mean soil moisture potential in MPa of the top 75 cm ! - ! that will prevent fires to happen. The dry air soil ! - ! potential is defined as -3.1 MPa, so make sure SM_FIRE is ! - ! greater than this value. ! + ! INCLUDE_FIRE -- Which threshold to use for fires. ! + ! 0. No fires; ! + ! 1. (deprecated) Fire will be triggered with enough biomass and ! + ! integrated ground water depth less than a threshold. Based on ! + ! ED-1, the threshold assumes that the soil is 1 m, so deeper ! + ! soils will need to be much drier to allow fires to happen and ! + ! often will never allow fires. ! + ! 2. Fire will be triggered with enough biomass and the total soil ! + ! water at the top 75 cm falls below a threshold. ! + ! FIRE_PARAMETER -- If fire happens, this will control the intensity of the disturbance ! + ! given the amount of fuel (currently the total above-ground ! + ! biomass). ! + ! SM_FIRE -- This is used only when INCLUDE_FIRE = 2. The sign here matters. ! + ! >= 0. - Minimum relative soil moisture above dry air of the top 1m ! + ! that will prevent fires to happen. ! + ! < 0. - Minimum mean soil moisture potential in MPa of the top 1m ! + ! that will prevent fires to happen. The dry air soil ! + ! potential is defined as -3.1 MPa, so make sure SM_FIRE is ! + ! greater than this value. ! !---------------------------------------------------------------------------------------! INCLUDE_FIRE = 2, + FIRE_PARAMETER = 1., SM_FIRE = -1.40, !---------------------------------------------------------------------------------------! @@ -2529,21 +2565,24 @@ $ED2_INFO !---------------------------------------------------------------------------------------! ! The following variables control the size of sub-polygon structures in ED-2. ! - ! MAXPATCH -- If number of patches in a given site exceeds MAXPATCH, force patch ! - ! fusion. If MAXPATCH is 0, then fusion will never happen. If MAXPATCH ! - ! is negative, then the absolute value is used only during the ! - ! initialization, and fusion will never happen again. Notice that if the ! - ! patches are too different, then the actual number of patches in a site ! - ! may exceed MAXPATCH. ! - ! MAXCOHORT -- If number of cohorts in a given patch exceeds MAXCOHORT, force cohort ! - ! fusion. If MAXCOHORT is 0, then fusion will never happen. If MAXCOHORT ! - ! is negative, then the absolute value is used only during the ! - ! initialization, and fusion will never happen again. Notice that if the ! - ! cohorts are too different, then the actual number of cohorts in a patch ! - ! may exceed MAXCOHORT. ! - !---------------------------------------------------------------------------------------! - MAXPATCH = 15, - MAXCOHORT = 100, + ! MAXPATCH -- If number of patches in a given site exceeds MAXPATCH, force patch ! + ! fusion. If MAXPATCH is 0, then fusion will never happen. If ! + ! MAXPATCH is negative, then the absolute value is used only during ! + ! the initialization, and fusion will never happen again. Notice ! + ! that if the patches are too different, then the actual number of ! + ! patches in a site may exceed MAXPATCH. ! + ! MAXCOHORT -- If number of cohorts in a given patch exceeds MAXCOHORT, force ! + ! cohort fusion. If MAXCOHORT is 0, then fusion will never happen. ! + ! If MAXCOHORT is negative, then the absolute value is used only ! + ! during the initialization, and fusion will never happen again. ! + ! Notice that if the cohorts are too different, then the actual ! + ! number of cohorts in a patch may exceed MAXCOHORT. ! + ! MIN_PATCH_AREA -- This is the minimum fraction area of a given soil type that allows ! + ! a site to be created (ignored if IED_INIT_MODE is set to 3). ! + !---------------------------------------------------------------------------------------! + MAXPATCH = 10, + MAXCOHORT = 60, + MIN_PATCH_AREA = 0.005, !---------------------------------------------------------------------------------------! diff --git a/BRAMS/src/catt/dry_dep.f90 b/BRAMS/src/catt/dry_dep.f90 index 3b4da1781..4055b96a2 100644 --- a/BRAMS/src/catt/dry_dep.f90 +++ b/BRAMS/src/catt/dry_dep.f90 @@ -77,7 +77,7 @@ subroutine dry_dep(ngrid,m1,m2,m3,npatch,ia,iz,ja,jz,jdim,dt & ,ustar,tstar,patch_area,veg,Z0m & ,v_dep_pm25, maxgrds,dzt,zt,nzpmax,naddsc ) - USE rconstants , ONLY : cpi,cpor,p00 + USE rconstants , ONLY : cpdryi,cpor,p00 USE mem_scalar , ONLY : scalar_g IMPLICIT NONE @@ -132,7 +132,7 @@ subroutine dry_dep(ngrid,m1,m2,m3,npatch,ia,iz,ja,jz,jdim,dt & do j = ja,jz do i = ia,iz rvs (i,j) = rv(2,i,j) - pis = (pp(1,i,j) + pp(2,i,j) + pi0(1,i,j) + pi0(2,i,j))*.5 * cpi + pis = (pp(1,i,j) + pp(2,i,j) + pi0(1,i,j) + pi0(2,i,j))*.5 * cpdryi prss (i,j) = pis ** cpor * p00 dens (i,j) = ( dn0(1,i,j) + dn0(2,i,j) ) * .5 temps(i,j) = theta(2,i,j) * pis ! temps=theta*Exner/CP @@ -322,7 +322,7 @@ end subroutine sedim_particles subroutine lsl_particles(m2,m3,npatch,ia,iz,ja,jz & ,temps,dens,vels,rvs,Zi,ustar,tstar,patch_area,veg,Z0m & ,v_sed,r_lsl) - use rconstants, only: t00, vonk,cp,pi1,grav,boltzmann + use rconstants, only: t00, vonk,cpdry,pi1,grav,boltzmann use leaf_coms, only : min_patch_area implicit none REAL,PARAMETER :: ASP = 1.257 ! 1.249 @@ -425,12 +425,12 @@ subroutine lsl_particles(m2,m3,npatch,ia,iz,ja,jz & !- thermal conductivity of dry air (Kd) Kd = 0.023807 + 7.1128e-5*(temps(i,j) - t00) !- Eq.(2.3) !- Prandt number - Pr = n_air*Cp*(1.+0.859*rvs(i,j))/Kd !- Eq.(17.32) + Pr = n_air*cpdry*(1.+0.859*rvs(i,j))/Kd !- Eq.(17.32) !- energy moisture roughness lengths (Z0h) !- Eq.(8.10) !-- molecular thermal diffusion coeff. (m^2 s^-1) - Dh=Kd/(dens(i,j)*Cp) + Dh=Kd/(dens(i,j)*cpdry) !- Z0h Z0h=Dh/(vonK*ustar(i,j,ipatch)) diff --git a/BRAMS/src/catt/extra.f90 b/BRAMS/src/catt/extra.f90 index 4f8b79eae..36f537e62 100644 --- a/BRAMS/src/catt/extra.f90 +++ b/BRAMS/src/catt/extra.f90 @@ -1,228 +1,300 @@ +!==========================================================================================! +!==========================================================================================! +! Module with extra stuff used by CATT. ! +!------------------------------------------------------------------------------------------! module extras - ! Used in CATT - implicit none + implicit none - integer, parameter :: na_extra2d=4, na_extra3d=6 + integer, parameter :: na_extra2d=4 + integer, parameter :: na_extra3d=6 - type ext2d - real,pointer,dimension(:,:) :: d2 - end type ext2d - type ext3d - real,pointer,dimension(:,:,:) :: d3 - end type ext3d + type ext2d + real, pointer, dimension(:,:) :: d2 + end type ext2d + type(ext2d), dimension(:,:), allocatable :: extra2d + type(ext2d), dimension(:,:), allocatable :: extra2dm - type(ext2d),allocatable :: extra2d(:,:),extra2dm(:,:) - ! extrad3d(indice,ngrid) - type(ext3d),allocatable :: extra3d(:,:),extra3dm(:,:) + type ext3d + real, pointer, dimension(:,:,:) :: d3 + end type ext3d + type(ext3d), dimension(:,:), allocatable :: extra3d + type(ext3d), dimension(:,:), allocatable :: extra3dm -contains + !=======================================================================================! + !=======================================================================================! - subroutine alloc_extra2d(scal,m1,m2,na2d,ngrid) - implicit none + contains - type (ext2d),intent(INOUT) :: scal(:,:) - integer,intent(IN) :: m1,m2 !Dimension of arrays - integer,intent(IN) :: na2d ! number of 2d extras arrays without ngrid - integer,intent(IN) :: ngrid - integer :: j - do j=1,na2d - allocate(scal(j,ngrid)%d2(m1,m2)) - end do - end subroutine alloc_extra2d + !=======================================================================================! + !=======================================================================================! + ! Allocate arrays. ! + !---------------------------------------------------------------------------------------! + subroutine alloc_extra2d(scal,m1,m2) - !--------------------------------------------------------------- + implicit none + !----- Arguments. -------------------------------------------------------------------! + type (ext2d), intent(inout) :: scal + integer , intent(in) :: m1 ! dimension of arrays + integer , intent(in) :: m2 ! dimension of arrays + !------------------------------------------------------------------------------------! - subroutine alloc_extra3d(scal,m1,m2,m3,na3d,ngrid) + allocate(scal%d2(m1,m2)) - implicit none + return + end subroutine alloc_extra2d + !=======================================================================================! + !=======================================================================================! - type (ext3d),intent(INOUT) :: scal(:,:) - integer,intent(IN) :: m1,m2,m3 !Dimension of arrays - integer,intent(IN) :: na3d ! number of 2d extras arrays without ngrid - integer,intent(IN) :: ngrid - integer :: j - do j=1,na3d - allocate(scal(j,ngrid)%d3(m1,m2,m3)) - end do - end subroutine alloc_extra3d - !--------------------------------------------------------------- - subroutine dealloc_extra2d(scal,na2d,ngrid) - implicit none - type (ext2d),intent(INOUT) :: scal(:,:) - integer,intent(in) :: ngrid,na2d - integer :: nsc,nd + !=======================================================================================! + !=======================================================================================! + ! Deallocate arrays. ! + !---------------------------------------------------------------------------------------! + subroutine dealloc_extra2d(scal) - ! Deallocate arrays + implicit none - do nd=1,na2d - do nsc=1,ngrid - if (associated(scal(nd,nsc)%d2)) deallocate (scal(nd,nsc)%d2) - enddo - end do + !----- Arguments. -------------------------------------------------------------------! + type (ext2d), intent(inout) :: scal + !------------------------------------------------------------------------------------! - end subroutine dealloc_extra2d + if (associated(scal%d2)) deallocate(scal%d2) - !--------------------------------------------------------------- + return + end subroutine dealloc_extra2d + !=======================================================================================! + !=======================================================================================! - subroutine dealloc_extra3d(scal,na3d,ngrid) - implicit none - type (ext3d),intent(INOUT) :: scal(:,:) - integer,intent(in) :: ngrid,na3d - integer :: nsc,nd - ! Deallocate arrays - do nd=1,na3d - do nsc=1,ngrid - if (associated(scal(nd,nsc)%d3)) deallocate (scal(nd,nsc)%d3) - enddo - end do - end subroutine dealloc_extra3d + !=======================================================================================! + !=======================================================================================! + ! Nullify arrays. ! + !---------------------------------------------------------------------------------------! + subroutine nullify_extra2d(scal) - !--------------------------------------------------------------- + implicit none - subroutine nullify_extra2d(scal,na2d,ngrid) + !----- Arguments. -------------------------------------------------------------------! + type (ext2d), intent(inout) :: scal + !------------------------------------------------------------------------------------! - implicit none + nullify (scal%d2) - type (ext2d),intent(INOUT) :: scal(:,:) - integer,intent(in) :: na2d,ngrid - integer :: nsc,nd + return + end subroutine nullify_extra2d + !=======================================================================================! + !=======================================================================================! - ! Deallocate arrays - do nd=1,na2d - do nsc=1,ngrid - if (associated(scal(nd,ngrid)%d2)) nullify (scal(nd,ngrid)%d2) - enddo - enddo - return - end subroutine nullify_extra2d - !--------------------------------------------------------------- - subroutine nullify_extra3d(scal,na3d,ngrid) + !=======================================================================================! + !=======================================================================================! + ! Initialise arrays. ! + !---------------------------------------------------------------------------------------! + subroutine zero_extra2d(scal) - implicit none + implicit none - type (ext3d),intent(INOUT) :: scal(:,:) - integer,intent(in) :: na3d,ngrid - integer :: nsc,nd + !----- Arguments. -------------------------------------------------------------------! + type (ext2d), intent(inout) :: scal + !------------------------------------------------------------------------------------! - ! Deallocate arrays + if(associated(scal%d2)) scal%d2(:,:) = 0.0 - do nd=1,na3d - do nsc=1,ngrid - if (associated(scal(nd,ngrid)%d3)) nullify (scal(nd,ngrid)%d3) - enddo - enddo + return - return - end subroutine nullify_extra3d + end subroutine zero_extra2d + !=======================================================================================! + !=======================================================================================! - !--------------------------------------------------------------- - subroutine filltab_extra2d(scal2,scalm2,imean,n1,n2,ng,na) - use var_tables - implicit none - type (ext2d) :: scal2,scalm2 - integer, intent(in) :: imean,n1,n2,ng,na - integer :: npts - character (len=7) :: sname - ! Fill pointers to arrays into variable tables + !=======================================================================================! + !=======================================================================================! + ! Fill pointers to arrays into variable tables. ! + !---------------------------------------------------------------------------------------! + subroutine filltab_extra2d(scal2,scalm2,imean,n1,n2,ng,na) + use var_tables + implicit none + !----- Arguments. -------------------------------------------------------------------! + type(ext2d), intent(inout) :: scal2 + type(ext2d), intent(inout) :: scalm2 + integer , intent(in) :: imean + integer , intent(in) :: n1 + integer , intent(in) :: n2 + integer , intent(in) :: ng + integer , intent(in) :: na + !----- Local variables. -------------------------------------------------------------! + integer :: npts + character (len=7) :: sname + !------------------------------------------------------------------------------------! - if (associated(scal2%d2)) then - npts=n1*n2 - write(sname,'(a2,i3.3)') 'd2', na - call vtables2 (scal2%d2,scalm2%d2 & - ,ng, npts, imean, & - trim(sname)//' :2:hist:anal:mpti:mpt3') ! Default - Column oriented Proc. + if (associated(scal2%d2)) then + npts = n1*n2 + write(sname,'(a2,i3.3)') 'd2', na + call vtables2 (scal2%d2,scalm2%d2,ng, npts, imean & + ,trim(sname)//' :2:hist:anal:mpti:mpt3') + end if + return + end subroutine filltab_extra2d + !=======================================================================================! + !=======================================================================================! - endif - end subroutine filltab_extra2d - !--------------------------------------------------------------- - subroutine filltab_extra3d(scal3,scalm3,imean,n1,n2,n3,ng,na) - use var_tables - implicit none - type (ext3d) :: scal3,scalm3 - integer, intent(in) :: imean,n1,n2,n3,ng,na + !=======================================================================================! + !=======================================================================================! + ! Allocate arrays. ! + !---------------------------------------------------------------------------------------! + subroutine alloc_extra3d(scal,m1,m2,m3) - integer :: npts - character (len=7) :: sname + implicit none + !----- Arguments. -------------------------------------------------------------------! + type (ext3d), intent(inout) :: scal + integer , intent(in) :: m1 ! dimension of arrays + integer , intent(in) :: m2 ! dimension of arrays + integer , intent(in) :: m3 ! dimension of arrays + !------------------------------------------------------------------------------------! - ! Fill pointers to arrays into variable tables + allocate(scal%d3(m1,m2,m3)) - if (associated(scal3%d3)) then - npts=n1*n2*n3 - write(sname,'(a2,i3.3)') 'd3', na - call vtables2 (scal3%d3,scalm3%d3 & - ,ng, npts, imean, & - sname//' :3:hist:anal:mpti:mpt3') ! Default - Column oriented Proc. + return + end subroutine alloc_extra3d + !=======================================================================================! + !=======================================================================================! - endif - return - end subroutine filltab_extra3d - !----------------------------------------------------------------- - subroutine zero_extra3d(scal,na3d,ngrid) - implicit none - type (ext3d),intent(INOUT) :: scal(:,:) - integer,intent(in) :: na3d,ngrid - integer :: nsc - ! Deallocate arrays + !=======================================================================================! + !=======================================================================================! + ! Deallocate arrays. ! + !---------------------------------------------------------------------------------------! + subroutine dealloc_extra3d(scal) - do nsc=1,na3d - scal(nsc,ngrid)%d3(:,:,:)=0. - enddo + implicit none - return - end subroutine zero_extra3d + !----- Arguments. -------------------------------------------------------------------! + type (ext3d), intent(inout) :: scal + !------------------------------------------------------------------------------------! - !----------------------------------------------------------------- - subroutine zero_extra2d(scal,na2d,ngrid) + if (associated(scal%d3)) deallocate(scal%d3) - implicit none + return + end subroutine dealloc_extra3d + !=======================================================================================! + !=======================================================================================! - type (ext2d),intent(INOUT) :: scal(:,:) - integer,intent(in) :: na2d,ngrid - integer :: nsc - ! Deallocate arrays - do nsc=1,na2d - scal(nsc,ngrid)%d2(:,:)=0. - enddo - return - end subroutine zero_extra2d + !=======================================================================================! + !=======================================================================================! + ! Nullify arrays. ! + !---------------------------------------------------------------------------------------! + subroutine nullify_extra3d(scal) + + implicit none + + !----- Arguments. -------------------------------------------------------------------! + type (ext3d), intent(inout) :: scal + !------------------------------------------------------------------------------------! + + nullify (scal%d3) + + return + end subroutine nullify_extra3d + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! Initialise arrays. ! + !---------------------------------------------------------------------------------------! + subroutine zero_extra3d(scal) + + implicit none + + !----- Arguments. -------------------------------------------------------------------! + type (ext3d), intent(inout) :: scal + !------------------------------------------------------------------------------------! + + if(associated(scal%d3)) scal%d3(:,:,:) = 0.0 + + return + + end subroutine zero_extra3d + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! Fill pointers to arrays into variable tables. ! + !---------------------------------------------------------------------------------------! + subroutine filltab_extra3d(scal3,scalm3,imean,n1,n2,n3,ng,na) + use var_tables + implicit none + !----- Arguments. -------------------------------------------------------------------! + type(ext3d), intent(inout) :: scal3 + type(ext3d), intent(inout) :: scalm3 + integer , intent(in) :: imean + integer , intent(in) :: n1 + integer , intent(in) :: n2 + integer , intent(in) :: n3 + integer , intent(in) :: ng + integer , intent(in) :: na + !----- Local variables. -------------------------------------------------------------! + integer :: npts + character (len=7) :: sname + !------------------------------------------------------------------------------------! + + if (associated(scal3%d3)) then + npts = n1*n2*n3 + write(sname,'(a2,i3.3)') 'd3', na + call vtables2 (scal3%d3,scalm3%d3,ng, npts, imean & + ,trim(sname)//' :3:hist:anal:mpti:mpt3') + end if + return + end subroutine filltab_extra3d + !=======================================================================================! + !=======================================================================================! + end module extras +!==========================================================================================! +!==========================================================================================! diff --git a/BRAMS/src/catt/plumerise_vector.f90 b/BRAMS/src/catt/plumerise_vector.f90 index 37a3b490a..17c2387ac 100644 --- a/BRAMS/src/catt/plumerise_vector.f90 +++ b/BRAMS/src/catt/plumerise_vector.f90 @@ -552,8 +552,8 @@ SUBROUTINE Get_Env_Condition(k1,k2,kmt,thtcon,picon,rvcon,zcon,qvenv, & DO k=1,nkp DO ij=ijbeg,ijend IF(k>kmt(ij)) CYCLE - te(ij,k) = the(ij,k)*pke(ij,k)/cp ! temperature (K) - pe(ij,k) = (pke(ij,k)/cp)**cpor*p00 ! pressure (Pa) + te(ij,k) = the(ij,k)*pke(ij,k)/cpdry ! temperature (K) + pe(ij,k) = (pke(ij,k)/cpdry)**cpor*p00 ! pressure (Pa) dne(ij,k)= pe(ij,k)/(rdry*virtt(te(ij,k),qvenv(ij,k))) ! dry air density (kg/m3) ! print*,'ENV=',qvenv(k)*1000., te(k)-t00,zt(k) END DO @@ -789,7 +789,7 @@ SUBROUTINE Makeplume(kmt,ztopmax,zm,dzm,zt,dz, & !********************************************************************** USE plume_utils, ONLY: ijindex,indexj,indexi - use rconstants, only : grav,rdry,cp,ep,alvi,alvl,alli + use rconstants, only : grav,rdry,cpdry,ep,alvi3,alvl3,alli IMPLICIT NONE ! ******************* SOME CONSTANTS ********************************** ! @@ -1263,7 +1263,7 @@ SUBROUTINE Lbound(imm,iveg_ag,qh,qi,qc,rsurf,plume_2d,iveg,ijbeg,ijend,alpha,& ! QC(1). ! EFLUX = energy flux at ground,watt/m**2 for the last DT ! - use rconstants, only: grav,rdry,cp,ep,pi1 + use rconstants, only: grav,rdry,cpdry,ep,pi1 USE plume_utils, ONLY: indexi,indexj implicit none @@ -1323,7 +1323,7 @@ SUBROUTINE Lbound(imm,iveg_ag,qh,qi,qc,rsurf,plume_2d,iveg,ijbeg,ijend,alpha,& pres = pe(ij,1) * 1000. !need pressure in n/m**2 c1 = 5. / (6. * alpha) !alpha is entrainment constant c2 = 0.9 * alpha - f = eflux / (pres * cp * pi1) + f = eflux / (pres * cpdry * pi1) f = grav * rdry * f * plume_2d(ij,iveg_ag) !buoyancy flux zv = c1 * rsurf(ij,iveg_ag) !virtual boundary height @@ -1345,7 +1345,7 @@ SUBROUTINE Lbound(imm,iveg_ag,qh,qi,qc,rsurf,plume_2d,iveg,ijbeg,ijend,alpha,& !advc = 0. !advh = 0. !advi = 0. - !adiabat = - wbar * g / cp + !adiabat = - wbar * g / cpdry vth(ij,1) = - 4. vti(ij,1) = - 3. txs(ij,1) = temp(ij,1) - te(ij,1) @@ -1440,15 +1440,15 @@ SUBROUTINE Evaporate(l,nkp,qsat,qv,wbar,dqsdz,dt,qh,qi,qc,temp,rho,est,cvi,ijbeg ! !- evaporates cloud,rain and ice to saturation ! - use rconstants, only: cp, alvl,alvi + use rconstants, only: cpdry, alvl3,alvi3 IMPLICIT NONE ! ! XNO=10.0E06 ! HERC = 1.93*1.E-6*XN035 !evaporation constant ! - REAL,PARAMETER :: herc = 5.44e-4, heatcond = alvl/1000. - REAL,PARAMETER :: heatsubl = alvi/1000., tmelt = 273., tfreeze = 269.3 - REAL,PARAMETER :: frc = heatcond / cp, src = heatsubl / cp + REAL,PARAMETER :: herc = 5.44e-4, heatcond = alvl3/1000. + REAL,PARAMETER :: heatsubl = alvi3/1000., tmelt = 273., tfreeze = 269.3 + REAL,PARAMETER :: frc = heatcond / cpdry, src = heatsubl / cpdry INTEGER,INTENT(IN) :: l,nkp,ijbeg,ijend REAL ,INTENT(IN),DIMENSION(ijbeg:ijend):: wbar,dqsdz,dt @@ -1663,11 +1663,11 @@ END SUBROUTINE Evaporate !----------------------------------- SUBROUTINE Sublimate(l,nkp,qv,qi,temp,dt,qsat,rho,est,ijbeg,ijend,nottodo) - use rconstants, only: alvi,alli,cp + use rconstants, only: alvi3,alli,cpdry ! ! ********************* VAPOR TO ICE (USE EQUATION OT22)*************** ! - REAL,PARAMETER :: src = alvi / cp, frc = alli / cp, tmelt = 273.3 + REAL,PARAMETER :: src = alvi3 / cpdry, frc = alli / cpdry, tmelt = 273.3 REAL,PARAMETER :: tfreeze = 269.3 INTEGER,INTENT(IN) :: l,nkp,ijbeg,ijend @@ -1728,13 +1728,13 @@ END SUBROUTINE Sublimate !------------------------------------------------------ SUBROUTINE Glaciate(l,nkp,qh,qi,temp,qsat,dt,qv,ijbeg,ijend,nottodo) - use rconstants, only: alli,cp,ep,alvi + use rconstants, only: alli,cpdry,ep,alvi3 ! ! *********************** CONVERSION OF RAIN TO ICE ******************* ! uses equation OT 16, simplest. correction from W not applied, but ! vapor pressure differences are supplied. ! - REAL,PARAMETER :: frc = alli / cp, frs = alvi/cp, tfreeze = 269.3 + REAL,PARAMETER :: frc = alli / cpdry, frs = alvi3/cpdry, tfreeze = 269.3 REAL,PARAMETER :: glconst = 0.025 !glaciation time constant, 1/sec INTEGER,INTENT(IN) :: l,nkp,ijbeg,ijend @@ -2216,7 +2216,7 @@ SUBROUTINE scl_misc(nm1,nkp,ijbeg,ijend,qvenv,te,vvel,temp,qv,qc,qh,qi, & tt,qvt,qct,qht,qit,radius,alpha,adiabat,wbar,isdone) USE plume_utils, ONLY: ijindex - use rconstants, only:grav,cp + use rconstants, only:grav,cpdry IMPLICIT NONE INTEGER,INTENT(IN) ,DIMENSION(ijbeg:ijend) :: nm1 @@ -2237,7 +2237,7 @@ SUBROUTINE scl_misc(nm1,nkp,ijbeg,ijend,qvenv,te,vvel,temp,qv,qc,qh,qi, & IF(isdone(ij) .OR. k>nm1(ij)-1) CYCLE wbar(ij) = 0.5*(vvel(ij,k)+vvel(ij,k-1)) !-- dry adiabat - adiabat = - wbar(ij) * grav / cp + adiabat = - wbar(ij) * grav / cpdry !-- entrainment dmdtm = 2. * alpha * abs (wbar(ij)) / radius (ij,k) != (1/m)dm/dt !-- tendency temperature = adv + adiab + entrainment @@ -2316,7 +2316,7 @@ END SUBROUTINE Damp_Grav_Wave SUBROUTINE Fallpart(nm1,nkp,qvt,qct,qht,qit,rho,vvel,qh,qi,zm, & vth,vti,cvi,ijbeg,ijend,isdone) - use rconstants, only: grav,cp,ep + use rconstants, only: grav,cpdry,ep IMPLICIT NONE REAL, PARAMETER :: vconst = 5.107387, f0 = 0.75 diff --git a/BRAMS/src/core/local_proc.f90 b/BRAMS/src/core/local_proc.f90 index cbe38f528..a1f4d5617 100644 --- a/BRAMS/src/core/local_proc.f90 +++ b/BRAMS/src/core/local_proc.f90 @@ -39,8 +39,8 @@ subroutine dtset_new(mynum, nndtflg, dxtmax_local) ! to determine the largest value. use rconstants, only : & - cp, & ! INTENT(IN) - cv, & ! INTENT(IN) + cpdry, & ! INTENT(IN) + cvdry, & ! INTENT(IN) rdry ! INTENT(IN) use ref_sounding, only : & @@ -52,7 +52,9 @@ subroutine dtset_new(mynum, nndtflg, dxtmax_local) maxgrds, & ! INTENT(IN) nzpmax, & ! INTENT(IN) frqanl ! INTENT(IN) - + use therm_lib, only : & + extheta2temp ! function + implicit none ! Arguments: @@ -111,10 +113,10 @@ subroutine dtset_new(mynum, nndtflg, dxtmax_local) n2 = nnxp(ifm) n3 = nnyp(ifm) do k = 1,nnzp(ifm) - vctr1(k) = th01dn(k,1) * pi01dn(k,1) / cp + vctr1(k) = extheta2temp(pi01dn(k,1),th01dn(k,1)) enddo tmax = maxval(vctr1(1:nnzp(ifm))) - ssmax = sqrt(cp / cv * rdry * tmax) + ssmax = sqrt(cpdry / cvdry * rdry * tmax) nn2 = nnxp(ifm) nn3 = nnyp(ifm) diff --git a/BRAMS/src/core/raco.f90 b/BRAMS/src/core/raco.f90 index 770219bcc..f68004189 100644 --- a/BRAMS/src/core/raco.f90 +++ b/BRAMS/src/core/raco.f90 @@ -686,7 +686,7 @@ subroutine coefz(m1,m2,m3,ia,iz,ja,jz & dt2al2 = dts a1da2 = 1. endif - rdto2cv = sspct ** 2 * rdry * dts / (2.0 * cv) + rdto2cv = sspct ** 2 * rdry * dts / (2.0 * cvdry) do j = ja,jz do i = ia,iz diff --git a/BRAMS/src/core/raco_adap.f90 b/BRAMS/src/core/raco_adap.f90 index 16079ac71..eddb59cd8 100644 --- a/BRAMS/src/core/raco_adap.f90 +++ b/BRAMS/src/core/raco_adap.f90 @@ -560,7 +560,7 @@ subroutine coefz_adap(m1,m2,m3,ia,iz,ja,jz,flpw & dt2al2 = dts a1da2 = 1. endif -rdto2cv = sspct ** 2 * rdry * dts / (2.0 * cv) +rdto2cv = sspct ** 2 * rdry * dts / (2.0 * cvdry) do j = ja,jz do i = ia,iz diff --git a/BRAMS/src/core/rnode.f90 b/BRAMS/src/core/rnode.f90 index 961d3fdf1..891b5e4c2 100644 --- a/BRAMS/src/core/rnode.f90 +++ b/BRAMS/src/core/rnode.f90 @@ -428,7 +428,8 @@ subroutine init_fields(init) !----- Arguments. ----------------------------------------------------------------------! logical, intent(in) :: init !----- Local variables. ----------------------------------------------------------------! - integer, dimension(ndim_types) :: npvar + integer, dimension(ndim_types) :: npvar_mpt1 + integer, dimension(ndim_types) :: npvar_mpt4 integer :: ierr integer :: hugedim integer :: ng @@ -441,14 +442,19 @@ subroutine init_fields(init) integer :: j2 integer :: xlbc integer :: ylbc + integer :: xadv + integer :: yadv integer :: xst integer :: yst integer :: fdzp integer :: fdep integer :: idim - integer :: memf + integer :: memf_mpt1 + integer :: memf_mpt4 + integer :: memf_st integer :: nv integer :: isflag + integer :: iaflag !----- Include modules. ----------------------------------------------------------------! include 'interface.h' include 'mpif.h' @@ -497,12 +503,25 @@ subroutine init_fields(init) !----- Find number of lbc variables to be communicated. --------------------------------! - npvar(:) = 0 + npvar_mpt1(:) = 0 + npvar_mpt4(:) = 0 do nv = 1,num_var(1) - if (vtab_r(nv,1)%impt1 == 1 ) then - idim = vtab_r(nv,1)%idim_type - npvar(idim) = npvar(idim) + 1 + idim = vtab_r(nv,1)%idim_type + + + !----- LBC variables. ---------------------------------------------------------------! + if (vtab_r(nv,1)%impt1 == 1 ) npvar_mpt1(idim) = npvar_mpt1(idim) + 1 + !------------------------------------------------------------------------------------! + + + !----- ADV variables. ---------------------------------------------------------------! + if (vtab_r(nv,1)%iadvt == 1 .or. vtab_r(nv,1)%iadvu == 1 .or. & + vtab_r(nv,1)%iadvv == 1 .or. vtab_r(nv,1)%iadvw == 1 .or. & + vtab_r(nv,1)%name == 'SCAL_IN' ) then + npvar_mpt4(idim) = npvar_mpt4(idim) + 1 end if + !------------------------------------------------------------------------------------! + end do !---------------------------------------------------------------------------------------! @@ -512,6 +531,7 @@ subroutine init_fields(init) ! Find the size of the lateral boundary condition buffers. ! !---------------------------------------------------------------------------------------! nbuff_feed = 0 + nbuff_adv = 0 do ng=1,ngrids do nm=1,nmachs i1 = ipaths(1,itype,ng,nm) @@ -521,13 +541,54 @@ subroutine init_fields(init) xlbc = i2 - i1 + 1 ylbc = j2 - j1 + 1 - memf = 0 + memf_mpt1 = 0 do idim = 2, ndim_types call ze_dims(ng,idim,.false.,fdzp,fdep) - memf = memf + fdzp * xlbc * ylbc * fdep * npvar(idim) + memf_mpt1 = memf_mpt1 + fdzp * xlbc * ylbc * fdep * npvar_mpt1(idim) end do - nbuff_feed = max(nbuff_feed,memf) + nbuff_feed = max(nbuff_feed,memf_mpt1) + end do + end do + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! Find the size of the advection lateral boundary condition buffers. ! + !---------------------------------------------------------------------------------------! + nbuff_adv = 0 + do ng=1,ngrids + do nm=1,nmachs + do iaflag=1,5 + + !----- Find the appropriate type. ---------------------------------------------! + select case (iaflag) + case (2,3) + jtype = iaflag + case default + jtype = 1 + end select + !------------------------------------------------------------------------------! + + i1 = ipaths(1,jtype,ng,nm) + i2 = ipaths(2,jtype,ng,nm) + j1 = ipaths(3,jtype,ng,nm) + j2 = ipaths(4,jtype,ng,nm) + xadv = i2 - i1 + 1 + yadv = j2 - j1 + 1 + + !------------------------------------------------------------------------------! + ! Add the number of points of all possible dimensions. ! + !------------------------------------------------------------------------------! + memf_mpt4 = 0 + do idim = 2, ndim_types + call ze_dims(ng,idim,.false.,fdzp,fdep) + memf_mpt4 = memf_mpt4 + fdzp * xadv * yadv * fdep * npvar_mpt4(idim) + end do + nbuff_adv = max(nbuff_adv ,memf_mpt4) + !------------------------------------------------------------------------------! + end do end do end do !---------------------------------------------------------------------------------------! @@ -553,9 +614,9 @@ subroutine init_fields(init) !------------------------------------------------------------------------------! ! The 2 is because depending on the type the package may have 2 variables. ! !------------------------------------------------------------------------------! - memf = 2 * fdzp * xst * yst * fdep + memf_st = 2 * fdzp * xst * yst * fdep - nbuff_st = max(nbuff_st,memf) + nbuff_st = max(nbuff_st,memf_st) end do end do end do @@ -585,6 +646,9 @@ subroutine init_fields(init) do isflag=1,6 call dealloc_node_buff(node_buffs_st(isflag,nm)) end do + do iaflag=1,5 + call dealloc_node_buff(node_buffs_adv(iaflag,nm)) + end do end do end if !---------------------------------------------------------------------------------------! @@ -609,6 +673,11 @@ subroutine init_fields(init) call dealloc_node_buff(node_buffs_st(isflag,nm)) call alloc_node_buff(node_buffs_st(isflag,nm),nbuff_st,f_ndmd_size) end do + + do iaflag=1,5 + call dealloc_node_buff(node_buffs_adv(iaflag,nm)) + call alloc_node_buff(node_buffs_adv(iaflag,nm),nbuff_adv,f_ndmd_size) + end do end if end do !---------------------------------------------------------------------------------------! @@ -619,7 +688,7 @@ subroutine init_fields(init) ! In case the boundary conditions are cyclic, initialise the cyclic structure. ! !---------------------------------------------------------------------------------------! if (ibnd == 4 .or. jbnd == 4) then - call node_cycinit(nnzp(1),nnxp(1),nnyp(1),npvar,nmachs,ibnd,jbnd,mynum) + call node_cycinit(nnzp(1),nnxp(1),nnyp(1),npvar_mpt1,nmachs,ibnd,jbnd,mynum) end if !---------------------------------------------------------------------------------------! diff --git a/BRAMS/src/core/rthrm.f90 b/BRAMS/src/core/rthrm.f90 index e6856c453..4a8d9fbc1 100644 --- a/BRAMS/src/core/rthrm.f90 +++ b/BRAMS/src/core/rthrm.f90 @@ -55,20 +55,14 @@ end subroutine thermo_boundary_driver !------------------------------------------------------------------------------------------! subroutine thermo(mzp,mxp,myp,ia,iz,ja,jz) - use mem_grid, only: & - ngrid ! ! intent(in) - Current grid - use mem_basic, only: & - basic_g ! ! intent(inout) - Structure with the "basic" variables - use mem_micro, only: & - micro_g ! ! intent(inout) - Structure containing the hydrometeors - use mem_scratch, only: & - scratch, & ! intent(out) - Scratch structure, for scratch... - vctr5, & ! intent(out) - Scratch vector, for scratch... - vctr6 ! ! intent(out) - Scratch vector, for scratch... - use therm_lib, only: & - level ! ! intent(in) - Number of H2O phases - use micphys, only: & - availcat ! ! intent(in) - Flag: the hydrometeor is available [T|F] + use mem_grid , only : ngrid ! ! intent(in) - Current grid + use mem_basic , only : basic_g ! ! intent(inout) - The "basic" variables + use mem_micro , only : micro_g ! ! intent(inout) - The hydrometeors + use mem_scratch, only : scratch & ! intent(out) - Scratch structure, for scratch... + , vctr5 & ! intent(out) - Scratch vector, for scratch... + , vctr6 ! ! intent(out) - Scratch vector, for scratch... + use therm_lib , only : level ! ! intent(in) - Number of H2O phases + use micphys , only : availcat ! ! intent(in) - Hydrometeor is available [T|F] implicit none !----- Arguments -----------------------------------------------------------------------! integer, intent(in) :: mzp ! # of points in Z [ ----] @@ -110,9 +104,15 @@ subroutine thermo(mzp,mxp,myp,ia,iz,ja,jz) !----- All three phases of water are allowed -------------------------------------------! case (3) mzxyp = mzp*mxp*myp - call azero3(mzxyp,scratch%vt3da,scratch%vt3db,scratch%vt3dc) - call azero3(mzxyp,scratch%vt3dd,scratch%vt3de,scratch%vt3df) - call azero3(mzxyp,scratch%vt3dg,scratch%vt3dh,scratch%vt3di) + call azero(mzxyp,scratch%vt3da) + call azero(mzxyp,scratch%vt3db) + call azero(mzxyp,scratch%vt3dc) + call azero(mzxyp,scratch%vt3dd) + call azero(mzxyp,scratch%vt3de) + call azero(mzxyp,scratch%vt3df) + call azero(mzxyp,scratch%vt3dg) + call azero(mzxyp,scratch%vt3dh) + call azero(mzxyp,scratch%vt3di) if (availcat(1)) call atob(mzxyp,micro_g(ngrid)%rcp,scratch%vt3da) if (availcat(2)) call atob(mzxyp,micro_g(ngrid)%rrp,scratch%vt3db) if (availcat(3)) call atob(mzxyp,micro_g(ngrid)%rpp,scratch%vt3dc) @@ -235,20 +235,16 @@ end subroutine vapthrm !==========================================================================================! !==========================================================================================! +! This routine diagnoses theta, rv, and rcp using a saturation adjustment for the case ! +! when water is in the liquid and vapour phases only. ! +!------------------------------------------------------------------------------------------! subroutine satadjst(m1,m2,m3,ia,iz,ja,jz,pp,p,thil,theta,t,pi0,rtp,rv,rcp,rvls) - !---------------------------------------------------------------------------------------! - ! This routine diagnoses theta, rv, and rcp using a saturation adjustment for the ! - ! case when water is in the liquid and vapour phases only. ! - !---------------------------------------------------------------------------------------! - use rconstants, only: & - cpi & ! intent(in) - ,p00 & ! intent(in) - ,alvl & ! intent(in) - ,cp & ! intent(in) - ,cpor ! ! intent(in) - !----- External functions --------------------------------------------------------------! - use therm_lib , only: & - rslf ! Sat. mixing ratio function + use therm_lib , only : rslf & ! function + , alvl & ! function + , exner2press & ! function + , extheta2temp & ! function + , extemp2theta & ! function + , thil2tqliq ! ! subroutine implicit none !----- Input arguments -----------------------------------------------------------------! @@ -275,14 +271,14 @@ subroutine satadjst(m1,m2,m3,ia,iz,ja,jz,pp,p,thil,theta,t,pi0,rtp,rv,rcp,rvls) do i = ia,iz do k = 1,m1 exner = (pi0(k,i,j) + pp(k,i,j)) - p(k,i,j) = p00 * (cpi* exner) ** cpor + p(k,i,j) = exner2press(exner) !----- First guess for temperature and liquid mixing ratio --------------------! - t(k,i,j) = cpi * thil(k,i,j) * exner + t(k,i,j) = extheta2temp(exner,thil(k,i,j)) rcp(k,i,j) = max(0.,rtp(k,i,j) - rslf(p(k,i,j),t(k,i,j))) !----- Adjusting the accordingly to the saturation point ----------------------! call thil2tqliq(thil(k,i,j),exner,p(k,i,j),rtp(k,i,j),rcp(k,i,j),t(k,i,j) & ,rv(k,i,j),rvls(k,i,j)) - theta(k,i,j) = cp * t(k,i,j) / exner + theta(k,i,j) = extemp2theta(exner,t(k,i,j)) end do end do end do @@ -299,25 +295,23 @@ end subroutine satadjst !==========================================================================================! !==========================================================================================! +! This routine calculates theta and rv for "level 3 microphysics" given prognosed ! +! theta_il, cloud, rain, pristine ice, snow, aggregates, graupel, hail, q6 (internal ! +! energy of graupel), and q7 (internal energy of hail). ! +!------------------------------------------------------------------------------------------! subroutine wetthrm3(m1,m2,m3,ia,iz,ja,jz,availcat,pi0,pp,thp,theta,rtp,rv,rcp,rrp,rpp,rsp & ,rap,rgp,rhp,q6,q7,rliq,rice) - !---------------------------------------------------------------------------------------! - ! This routine calculates theta and rv for "level 3 microphysics" - ! given prognosed theta_il, cloud, rain, pristine ice, snow, aggregates, - ! graupel, hail, q6, and q7. - - use rconstants, only : cpi & ! intent(in) - , cp & ! intent(in) - , cpor & ! intent(in) - , p00 & ! intent(in) - , ttripoli & ! intent(in) - , alvl & ! intent(in) - , alvi & ! intent(in) - , cpi4 & ! intent(in) - , htripolii ! ! intent(in) - use node_mod , only : mynum ! ! intent(in) - use therm_lib , only : thil2temp ! ! Theta_il => Temperature function + use rconstants, only : ttripoli & ! intent(in) + , alvl3 & ! intent(in) + , alvi3 & ! intent(in) + , cpdryi4 & ! intent(in) + , htripolii ! ! intent(in) + use node_mod , only : mynum ! ! intent(in) + use therm_lib , only : thil2temp & ! function + , exner2press & ! function + , extheta2temp & ! function + , extemp2theta ! ! function implicit none @@ -369,18 +363,19 @@ subroutine wetthrm3(m1,m2,m3,ia,iz,ja,jz,availcat,pi0,pp,thp,theta,rtp,rv,rcp,rr !----- Finding the potential temperature -----------------------------------------! do k = 1,m1 exner = pi0(k,i,j) + pp(k,i,j) - pres = p00 * (cpi * exner)**cpor - !----- Finding the first guess ------------------------------------------------! - til = cpi * thp(k,i,j) * exner - temp = cpi * theta(k,i,j) * exner + pres = exner2press(exner) + !----- Find the first guess. --------------------------------------------------! + til = extheta2temp(exner,thp (k,i,j)) + temp = extheta2temp(exner,theta(k,i,j)) if (temp > ttripoli) then - temp = 0.5 * (til + sqrt(til * (til + cpi4*(alvl*rliq(k)+alvi*rice(k))))) + temp = 0.5 * ( til & + + sqrt( til * (til + cpdryi4 * (alvl3*rliq(k)+alvi3*rice(k))))) else - temp = til * (1. + htripolii * (alvl*rliq(k)+alvi*rice(k))) + temp = til * (1. + htripolii * (alvl3*rliq(k)+alvi3*rice(k))) endif !----- First guess for temperature --------------------------------------------! temp = thil2temp(thp(k,i,j),exner,pres,rliq(k),rice(k),temp) - theta(k,i,j) = cp * temp / exner + theta(k,i,j) = extemp2theta(exner,temp) if (rv(k,i,j) > rtp(k,i,j) .or. rliq(k) < 0. .or. rice(k) < 0.) then write (unit=*,fmt='(a)') '------ MODEL THERMODYNAMIC IS NON-SENSE... ------' @@ -430,7 +425,7 @@ subroutine integ_liq_ice(m1,availcat,rcp,rrp,rpp,rsp,rap,rgp,rhp,q6,q7,rliq,rice ! cumulus parametrisation also needs this part to find the first guess, but not the ! ! temperature and potential temperature part. ! !---------------------------------------------------------------------------------------! - use therm_lib, only: qtk + use therm_lib, only : uint2tl ! ! function implicit none !----- Input variables -----------------------------------------------------------------! integer , intent(in) :: m1 ! Vertical dimension [ ----] @@ -505,7 +500,7 @@ subroutine integ_liq_ice(m1,availcat,rcp,rrp,rpp,rsp,rap,rgp,rhp,q6,q7,rliq,rice !----- Graupel is mixed, find the liquid fraction and distribute to both phases --------! if (availcat(6)) then do k = 1,m1 - call qtk(q6(k),tcoal,frcliq) + call uint2tl(q6(k),tcoal,frcliq) rliq(k) = rliq(k) + rgp(k) * frcliq rice(k) = rice(k) + rgp(k) * (1. - frcliq) end do @@ -515,7 +510,7 @@ subroutine integ_liq_ice(m1,availcat,rcp,rrp,rpp,rsp,rap,rgp,rhp,q6,q7,rliq,rice !----- Hail is also mixed, do the same as graupel --------------------------------------! if (availcat(7)) then do k = 1,m1 - call qtk(q7(k),tcoal,frcliq) + call uint2tl(q7(k),tcoal,frcliq) rliq(k) = rliq(k) + rhp(k) * frcliq rice(k) = rice(k) + rhp(k) * (1. - frcliq) end do @@ -526,624 +521,3 @@ subroutine integ_liq_ice(m1,availcat,rcp,rrp,rpp,rsp,rap,rgp,rhp,q6,q7,rliq,rice end subroutine integ_liq_ice !==========================================================================================! !==========================================================================================! - - - - - - -!==========================================================================================! -!==========================================================================================! -! This subroutine computes a consistent set of temperature and condensated phases mix- ! -! ing ratio for a given theta_il, Exner function, and total mixing ratio. This is very ! -! similar to the function thil2temp, except that now we don't know rliq and rice, and for ! -! this reason they also become functions of temperature, since they are defined as ! -! rtot-rsat(T,p), remembering that rtot and p are known. If the air is not saturated, we ! -! rather use the fact that theta_il = theta and skip the hassle. Otherwise, we use iter- ! -! ative methods. We will always try Newton's method, since it converges fast. The caveat ! -! is that Newton may fail, and it actually does fail very close to the triple point, ! -! because the saturation vapour pressure function has a "kink" at the triple point ! -! (continuous, but not differentiable). If that's the case, then we fall back to a modifi- ! -! ed regula falsi (Illinois) method, which is a mix of secant and bisection and will ! -! converge. ! -!------------------------------------------------------------------------------------------! -subroutine thil2tqall(thil,exner,pres,rtot,rliq,rice,temp,rvap,rsat) - use rconstants, only : alvl,alvi,allii,cp,cpi,t00,toodry,t3ple,ttripoli - !----- External functions --------------------------------------------------------------! - use therm_lib , only : & - rslif & ! Function to compute sat. mixing ratio. - ,toler & ! Tolerance - ,theta_iceliq & ! Function to compute theta_il - ,dthetail_dt & ! d(Theta_il)/dT - ,maxfpo ! ! Maximum # of iterations before giving up. - - implicit none - - real, intent(in) :: thil ! Ice-liquid water potential temperature [ K] - real, intent(in) :: exner ! Exner function [J/kg/K] - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: rtot ! Total mixing ratio [ kg/kg] - real, intent(out) :: rliq ! Liquid water mixing ratio [ kg/kg] - real, intent(out) :: rice ! Ice mixing ratio [ kg/kg] - real, intent(inout) :: temp ! Temperature [ K] - real, intent(out) :: rvap ! Water vapour mixing ratio [ kg/kg] - real, intent(out) :: rsat ! Saturation water vapour mixing ratio [ kg/kg] - !----- Local variables -----------------------------------------------------------------! - real :: tempa,tempz ! Aux. vars for regula falsi iteration - real :: t1stguess ! Book keeping temperature 1st guess - real :: fun1st ! Book keeping 1st guess function - real :: funa,funz ! The functions for regula falsi - real :: funnow ! Function at this iteration. - real :: delta ! Aux. var in case we need regula falsi. - real :: deriv ! Derivative of this function. - integer :: itn,itb,ii ! Iteration counter - logical :: converged ! Convergence handle - logical :: zside ! Aux. Flag, for two purposes: - ! 1. Found a good 2nd guess for regula falsi. - ! 2. I retained the "zside" (T/F) - - t1stguess = temp - - !---------------------------------------------------------------------------------------! - ! First check: try to find temperature assuming sub-saturation and check if this ! - ! is the case. If it is, then there is no need to go through the iterative loop. ! - !---------------------------------------------------------------------------------------! - tempz = cpi * thil * exner - rsat = max(toodry,rslif(pres,tempz)) - if (tempz >= t3ple) then - rliq = max(0.,rtot-rsat) - rice = 0. - else - rice = max(0.,rtot-rsat) - rliq = 0. - end if - rvap = rtot-rliq-rice - - !---------------------------------------------------------------------------------------! - ! If rtot < rsat, this is not saturated, we can leave the subroutine and bypass the ! - ! iterative part. ! - !---------------------------------------------------------------------------------------! - if (rtot < rsat) then - temp = tempz - return - end if - - !---------------------------------------------------------------------------------------! - ! If not, then use the temperature the user gave as first guess and solve iterative- ! - ! ly. We use the user instead of what we just found because if the air is saturated, ! - ! then this can be too far off which may be bad for Newton's method. ! - !---------------------------------------------------------------------------------------! - tempz = temp - rsat = max(toodry,rslif(pres,tempz)) - if (tempz >= t3ple) then - rliq = max(0.,rtot-rsat) - rice = 0. - else - rice = max(0.,rtot-rsat) - rliq = 0. - end if - rvap = rtot-rliq-rice - - - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=46,fmt='(a)') '-------------------------------------------------------------' - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - - - !---------------------------------------------------------------------------------------! - ! Finding the function. We are seeking a temperature which is associated with the ! - ! theta_il we provided. Thus, the function is simply the difference between the ! - ! theta_il associated with our guess and the actual theta_il. ! - !---------------------------------------------------------------------------------------! - funnow = theta_iceliq(exner,tempz,rliq,rice) - !----- Updating the derivative. --------------------------------------------------------! - deriv = dthetail_dt(.false.,funnow,exner,pres,tempz,rliq,rice) - funnow = funnow - thil - fun1st = funnow - - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=46,fmt='(a,1x,i5,1x,6(a,1x,f11.4,1x),a,1x,es11.4,1x)') & - ! 'NEWTON: it=',0,'temp=',tempz-t00,'rsat=',1000.*rsat,'rliq=',1000.*rliq & - ! ,'rice=',1000.*rice,'rvap=',1000.*rvap,'fun=',funnow,'deriv=',deriv - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - - !---------------------------------------------------------------------------------------! - ! Now we enter at the Newton's method iterative loop. We are always going to try ! - ! this first, because it's fast, but if it turns out to be a dangerous choice or if it ! - ! doesn't converge fast, we will fall back to regula falsi. ! - ! We start by initialising the flag and copying temp to tempz, the newest guess. ! - !---------------------------------------------------------------------------------------! - converged=.false. - newloop: do itn=1,maxfpo/6 - !------------------------------------------------------------------------------------! - ! Saving previous guess. We also save the function is in case we withdraw ! - ! Newton's and switch to regula falsi. ! - !------------------------------------------------------------------------------------! - funa = funnow - tempa = tempz - - !----- Go to bisection if the derivative is too flat (too dangerous...) -------------! - if (abs(deriv) < toler) exit newloop - - tempz = tempa - funnow / deriv - - !----- Finding the mixing ratios associated with this guess -------------------------! - rsat = max(toodry,rslif(pres,tempz)) - if (tempz >= t3ple) then - rliq = max(0.,rtot-rsat) - rice = 0. - else - rice = max(0.,rtot-rsat) - rliq = 0. - end if - rvap = rtot-rliq-rice - - !----- Updating the function --------------------------------------------------------! - funnow = theta_iceliq(exner,tempz,rliq,rice) - !----- Updating the derivative. -----------------------------------------------------! - deriv = dthetail_dt(.false.,funnow,exner,pres,tempz,rliq,rice) - funnow = funnow - thil - - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>= t3ple) then - rliq = max(0.,rtot-rsat) - rice = 0. - else - rice = max(0.,rtot-rsat) - rliq = 0. - end if - rvap = rtot-rliq-rice - exit newloop - end if - - end do newloop - !---------------------------------------------------------------------------------------! - - !----- For debugging only --------------------------------------------------------------! - itb = itn+1 - - if (.not. converged) then - !------------------------------------------------------------------------------------! - ! If I reach this point, then it means that Newton's method failed finding the ! - ! equilibrium, so we are going to use the regula falsi instead. If Newton's method ! - ! didn't converge, we use tempa as one guess and now we seek a tempz with opposite ! - ! sign. ! - !------------------------------------------------------------------------------------! - !----- Check funa and funnow have opposite signs. If so, we are ready to go ---------! - if (funa*funnow < 0) then - funz = funnow - zside = .true. - !----- Otherwise, checking whether the 1st guess had opposite sign. -----------------! - elseif (funa*fun1st < 0 ) then - funz = fun1st - zside = .true. - !------------------------------------------------------------------------------------! - ! Looking for a guess. Extrapolate funa linearly, trying to get the -funa. We ! - ! don't need it to be funa, just with the opposite sign. If that's not enough, we ! - ! keep going further... Force the guesses to be at least 1K apart ! - !------------------------------------------------------------------------------------! - else - if (abs(funnow-funa) < 100.*toler*tempa) then - delta = 100.*toler*tempa - else - delta = max(abs(funa)*abs((tempz-tempa)/(funnow-funa)),100.*toler*tempa) - end if - tempz = tempa + delta - funz = funa - !----- Just to enter at least once. The 1st time tempz=tempa-2*delta -------------! - zside = .false. - zgssloop: do itb=1,maxfpo - tempz = tempa + real((-1)**itb * (itb+3)/2) * delta - rsat = max(toodry,rslif(pres,tempz)) - if (tempz >= t3ple) then - rliq = max(0.,rtot-rsat) - rice = 0. - else - rice = max(0.,rtot-rsat) - rliq = 0. - end if - rvap = rtot-rliq-rice - funz = theta_iceliq(exner,tempz,rliq,rice) - thil - zside = funa*funz < 0 - if (zside) exit zgssloop - end do zgssloop - if (.not. zside) then - write (unit=*,fmt='(60a1)') ('-',ii=1,60) - write (unit=*,fmt='(a)') ' THIL2TQALL: NO SECOND GUESS FOR YOU!' - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' -> Input: ' - write (unit=*,fmt='(a,1x,f12.5)') ' THETA_IL [ K]:',thil - write (unit=*,fmt='(a,1x,f12.5)') ' PRESS [ hPa]:',0.01*pres - write (unit=*,fmt='(a,1x,f12.5)') ' EXNER [J/kg/K]:',exner - write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1000.*rtot - write (unit=*,fmt='(a,1x,f12.5)') ' T1ST [ degC]:',t1stguess-t00 - write (unit=*,fmt='(a,1x,f12.5)') ' TEMPA [ degC]:',tempa-t00 - write (unit=*,fmt='(a,1x,f12.5)') ' TEMPZ [ degC]:',tempz-t00 - write (unit=*,fmt='(a,1x,f12.5)') ' FUNNOW [ K]:',funnow - write (unit=*,fmt='(a,1x,f12.5)') ' FUNA [ K]:',funa - write (unit=*,fmt='(a,1x,f12.5)') ' FUNZ [ K]:',funz - write (unit=*,fmt='(a,1x,f12.5)') ' DELTA [ K]:',delta - write (unit=*,fmt='(60a1)') ('-',ii=1,60) - - call abort_run('Failed finding the second guess for regula falsi' & - ,'thil2tqall','rthrm.f90') - end if - end if - !------------------------------------------------------------------------------------! - - !------------------------------------------------------------------------------------! - ! Now we loop until convergence is achieved. One important thing to notice is ! - ! that Newton's method fail only when T is almost T3ple, which means that ice and ! - ! liquid should be present, and we are trying to find the saturation point with all ! - ! ice or all liquid. This will converge but the final answer will contain signifi- ! - ! cant error. To reduce it we redistribute the condensates between ice and liquid ! - ! conserving the total condensed mixing ratio. ! - !------------------------------------------------------------------------------------! - fpoloop: do itb=itn,maxfpo - temp = (funz*tempa-funa*tempz)/(funz-funa) - !----- Checking whether this guess will fall outside the range -------------------! - if (abs(temp-tempa) > abs(tempz-tempa) .or. abs(temp-tempz) > abs(tempz-tempa)) & - temp = 0.5*(tempa+tempz) - !----- Distributing vapour into the three phases ---------------------------------! - rsat = max(toodry,rslif(pres,temp)) - rvap = min(rtot,rsat) - if (temp >= t3ple) then - rliq = max(0.,rtot-rsat) - rice = 0. - else - rliq = 0. - rice = max(0.,rtot-rsat) - end if - !----- Updating function ---------------------------------------------------------! - funnow = theta_iceliq(exner,temp,rliq,rice) - thil - - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=46,fmt='(a,1x,i5,1x,10(a,1x,f11.4,1x))') & - ! 'REGFAL: it=',itb,'temp=',temp-t00,'tempa=',tempa-t00,'tempz=',tempz-t00 & - ! ,'rsat=',1000.*rsat,'rliq=',1000.*rliq,'rice=',1000.*rice,'rvap=',1000.*rvap & - ! ,'fun=',funnow,'funa=',funa,'funz=',funz - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - - !---------------------------------------------------------------------------------! - ! Checking for convergence or lucky guess. If it did, return, we found the ! - ! solution. Otherwise, constrain the guesses. ! - !---------------------------------------------------------------------------------! - converged = abs(temp-tempa) < toler*temp .and. abs(temp-tempz) < toler*temp - if (funnow == 0. .or. converged) then - converged = .true. - exit fpoloop - elseif (funnow*funa < 0.) then - tempz = temp - funz = funnow - !----- If we are updating zside again, modify aside (Illinois method) ---------! - if (zside) funa=funa * 0.5 - !----- We just updated zside, setting zside to true. --------------------------! - zside = .true. - elseif (funnow*funz < 0.) then - tempa = temp - funa = funnow - !----- If we are updating aside again, modify zside (Illinois method) ---------! - if (.not.zside) funz = funz * 0.5 - !----- We just updated aside, setting zside to false --------------------------! - zside = .false. - end if - - end do fpoloop - - !------------------------------------------------------------------------------------! - ! Almost done... Usually when the method goes through regula falsi, it means that ! - ! the temperature is too close to the triple point, and often all three phases will ! - ! coexist. The problem with the method is that it converges for temperature, but ! - ! whenever regula falsi is called the function evaluation is usually far from zero. ! - ! This can be improved by finding a better partition between ice and liquid given ! - ! the temperature and saturation mixing ratio we just found. So just to round these ! - ! edges, we will invert the ice-liquid potential temperature using the set of tem- ! - ! perature and rsat, and fiding the liquid mixing ratio. ! - !------------------------------------------------------------------------------------! - if (abs(temp-t3ple) < toler*temp) then - rliq = min(rtot-rsat,max(0., & - allii*(alvi*(rtot-rsat)+cp*max(temp,ttripoli) & - *log(cpi*exner*thil/temp)))) - rice = max(0.,rtot-rsat-rliq) - funnow = theta_iceliq(exner,temp,rliq,rice) - thil - end if - - itb=itb+1 - end if - - if (.not. converged) then - write (unit=*,fmt='(60a1)') ('-',ii=1,60) - write (unit=*,fmt='(a)') ' THIL2TQALL failed!' - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' -> Input: ' - write (unit=*,fmt='(a,1x,f12.5)') ' THETA_IL [ K]:',thil - write (unit=*,fmt='(a,1x,f12.5)') ' EXNER [J/kg/K]:',exner - write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1000.*rtot - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' -> Output: ' - write (unit=*,fmt='(a,1x,i12)') ' ITERATIONS :',itb - write (unit=*,fmt='(a,1x,f12.5)') ' TEMP [ °C]:',temp-t00 - write (unit=*,fmt='(a,1x,f12.5)') ' RVAP [ g/kg]:',1000.*rvap - write (unit=*,fmt='(a,1x,f12.5)') ' RLIQ [ g/kg]:',1000.*rliq - write (unit=*,fmt='(a,1x,f12.5)') ' RICE [ g/kg]:',1000.*rice - write (unit=*,fmt='(a,1x,f12.5)') ' TEMPA [ °C]:',tempa-t00 - write (unit=*,fmt='(a,1x,f12.5)') ' TEMPZ [ °C]:',tempz-t00 - write (unit=*,fmt='(a,1x,es12.5)') ' FUNA [ K]:',funnow - write (unit=*,fmt='(a,1x,es12.5)') ' FUNZ [ K]:',funnow - write (unit=*,fmt='(a,1x,es12.5)') ' DERIV [ ---]:',deriv - write (unit=*,fmt='(a,1x,es12.5)') ' ERR_A [ ---]:',abs(temp-tempa)/temp - write (unit=*,fmt='(a,1x,es12.5)') ' ERR_Z [ ---]:',abs(temp-tempz)/temp - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(60a1)') ('-',ii=1,60) - call abort_run('Failed finding equilibrium, I gave up!','thil2tqall','rthrm.f90') - end if - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=46,fmt='(a,1x,i5,1x,6(a,1x,f11.4,1x))') & - ! 'ANSWER: it=',itb,'funf=',funnow,'temp=',temp-t00 & - ! ,'rsat=',1000.*rsat,'rliq=',1000.*rliq,'rice=',1000.*rice,'rvap=',1000.*rvap - !write (unit=46,fmt='(a)') '-------------------------------------------------------------' - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - return -end subroutine thil2tqall -!==========================================================================================! -!==========================================================================================! - - - - - - -!==========================================================================================! -!==========================================================================================! -! This subroutine computes a consistent set of temperature and condensated phases mix- ! -! ing ratio for a given theta_il, Exner function, and total mixing ratio. This is very ! -! similar to the function thil2temp, except that now we don't know rliq. Rliq becomes ! -! function of temperature, since it is defined as rtot-rsat(T,p), remembering that rtot ! -! and p are known. If the air is not saturated, we rather use the fact that theta_il = ! -! theta and skip the hassle. Otherwise, we use iterative methods. We will always try ! -! Newton's method, since it converges fast. Not always will Newton converge, and if that's ! -! the case we use a modified regula falsi (Illinois) method. This method is a mix of sec- ! -! ant and bisection and will always converge. ! -!------------------------------------------------------------------------------------------! -subroutine thil2tqliq(thil,exner,pres,rtot,rliq,temp,rvap,rsat) - use rconstants, only : alvl,cp,cpi,toodry,ttripoli - - !----- External functions --------------------------------------------------------------! - use therm_lib , only : & - rslf & ! Function to compute sat. mixing ratio. - ,theta_iceliq & ! Function to compute theta_il for a given state - ,dthetail_dt & ! Function to compute d(theta_il)/dT - ,toler & ! Tolerance - ,maxfpo ! ! Maximum # of iterations before giving up. - implicit none - - real, intent(in) :: thil ! Ice-liquid water potential temperature [ K] - real, intent(in) :: exner ! Exner function [J/kg/K] - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: rtot ! Total mixing ratio [ kg/kg] - real, intent(out) :: rliq ! Liquid water mixing ratio [ kg/kg] - real, intent(inout) :: temp ! Temperature [ K] - real, intent(out) :: rvap ! Water vapour mixing ratio [ kg/kg] - real, intent(out) :: rsat ! Saturation water vapour mixing ratio [ kg/kg] - !----- Local variables -----------------------------------------------------------------! - real :: tempa,tempz ! Aux. vars for regula falsi iteration - real :: funa,funz ! The functions for regula falsi - real :: funnow ! Function at this iteration. - real :: delta ! Aux. var in case we need regula falsi. - real :: deriv ! Derivative of this function. - integer :: itn,itb ! Iteration counter - logical :: converged ! Convergence handle - logical :: zside ! Aux. Flag, for two purposes: - ! 1. Found a good 2nd guess for regula falsi. - ! 2. I retained the "zside" (T/F) - - !---------------------------------------------------------------------------------------! - ! First check: try to find temperature assuming sub-saturation and check if this ! - ! is the case. If it is, then there is no need to go through the iterative loop. ! - !---------------------------------------------------------------------------------------! - tempz = cpi * thil * exner - rsat = max(toodry,rslf(pres,tempz)) - rliq = max(0.,rtot-rsat) - rvap = rtot-rliq - - !---------------------------------------------------------------------------------------! - ! If rtot < rsat, this is not saturated, we can leave the subroutine and bypass the ! - ! iterative part. ! - !---------------------------------------------------------------------------------------! - if (rtot < rsat) then - temp = tempz - return - end if - - !---------------------------------------------------------------------------------------! - ! If not, then use the temperature the user gave as first guess and solve iterative- ! - ! ly. We use the user instead of what we just found because if the air is saturated, ! - ! then this can be too far off which may be bad for Newton's method. ! - !---------------------------------------------------------------------------------------! - tempz = temp - rsat = max(toodry,rslf(pres,tempz)) - rliq = max(0.,rtot-rsat) - rvap = rtot-rliq - - - !---------------------------------------------------------------------------------------! - ! Finding the function and its derivative. We are seeking a temperature which is ! - ! associated with the theta_il we provided. Thus, the function is simply the difference ! - ! between the theta_il associated with our guess and the actual theta_il. ! - ! To find the derivative, we use the fact that rliq = rtot - rsat(T,p). When ! - ! T < T(Tripoli), then the temperature at the denominator becomes constant so the ! - ! derivative becomes different. ! - !---------------------------------------------------------------------------------------! - funnow = theta_iceliq(exner,tempz,rliq,0.) ! Finding thil from our guess - deriv = dthetail_dt(.false.,funnow,exner,pres,tempz,rliq) - funnow = funnow - thil ! Computing the function - - - !---------------------------------------------------------------------------------------! - ! Now we enter at the Newton's method iterative loop. We are always going to try ! - ! this first, because it's fast, but if it turns out to be a dangerous choice or if it ! - ! doesn't converge fast, we will fall back to regula falsi. ! - ! We start by initialising the flag and copying temp to tempz, the newest guess. ! - !---------------------------------------------------------------------------------------! - converged=.false. - newloop: do itn=1,maxfpo/6 - !------------------------------------------------------------------------------------! - ! Saving previous guess. We also save the function is in case we withdraw ! - ! Newton's and switch to regula falsi. ! - !------------------------------------------------------------------------------------! - funa = funnow - tempa = tempz - - !----- Go to bisection if the derivative is too flat (too dangerous...) -------------! - if (abs(deriv) < toler) exit newloop - - tempz = tempa - funnow / deriv - - !----- Finding the mixing ratios associated with this guess -------------------------! - rsat = max(toodry,rslf(pres,tempz)) - rliq = max(0.,rtot-rsat) - rvap = rtot-rliq - - !----- Updating the function and its derivative -------------------------------------! - funnow = theta_iceliq(exner,tempz,rliq,0.) - deriv = dthetail_dt(.false.,funnow,exner,pres,tempz,rliq) - funnow = funnow - thil - - converged = abs(tempa-tempz) < toler*tempz - !------------------------------------------------------------------------------------! - ! Convergence. The temperature will be the mid-point between tempa and tempz. Fix ! - ! the mixing ratios and return. Just check for the lucky guess, it actually happens ! - ! sometimes and if not checked, it becomes a singularity of this method. ! - !------------------------------------------------------------------------------------! - if (funnow == 0.) then - temp = tempz - converged = .true. - exit newloop - elseif (converged) then - temp = 0.5 * (tempa+tempz) - rsat = max(toodry,rslf(pres,temp)) - rliq = max(0.,rtot-rsat) - rvap = rtot-rliq - exit newloop - end if - - end do newloop - !---------------------------------------------------------------------------------------! - - - if (.not. converged) then - !------------------------------------------------------------------------------------! - ! If I reach this point, then it means that Newton's method failed finding the ! - ! equilibrium, so we are going to use the regula falsi instead. If Newton's method ! - ! didn't converge, we use tempa as one guess and now we seek a tempz with opposite ! - ! sign. ! - !------------------------------------------------------------------------------------! - !----- Check funa and funnow have opposite signs. If so, we are ready to go ---------! - if (funa*funnow < 0) then - funz = funnow - zside = .true. - !------------------------------------------------------------------------------------! - ! Looking for a guess. Extrapolate funa linearly, trying to get the -funa. We ! - ! don't need it to be funa, just with the opposite sign. If that's not enough, we ! - ! keep going further... ! - !------------------------------------------------------------------------------------! - else - if (abs(funnow-funa) < toler*tempa) then - delta = 100.*toler*tempa - else - delta = max(abs(funa*(tempz-tempa)/(funnow-funa)),100.*toler*tempa) - end if - tempz = tempa + delta - funz = funa - !----- Just to enter at least once. The 1st time tempz=tempa-2*delta -------------! - zside = .false. - zgssloop: do itb=1,maxfpo - tempz = tempz + real((-1)**itb * (itb+3)/2) * delta - rsat = max(toodry,rslf(pres,tempz)) - rliq = max(0.,rtot-rsat) - rvap = rtot-rliq - funz = theta_iceliq(exner,tempz,rliq,0.) - thil - zside = funa*funz < 0 - if (zside) exit zgssloop - end do zgssloop - if (.not. zside) & - call abort_run('Failed finding the second guess for regula falsi' & - ,'thil2tqliq','rthrm.f90') - end if - !------------------------------------------------------------------------------------! - - !------------------------------------------------------------------------------------! - ! Now we loop until convergence is achieved. ! - !------------------------------------------------------------------------------------! - fpoloop: do itb=itn,maxfpo - temp = (funz*tempa-funa*tempz)/(funz-funa) - !----- Distributing vapour into the three phases ---------------------------------! - rsat = max(toodry,rslf(pres,temp)) - rvap = min(rtot,rsat) - rliq = max(0.,rtot-rsat) - !----- Updating function ---------------------------------------------------------! - funnow = theta_iceliq(exner,tempz,rliq,0.) - thil - - !---------------------------------------------------------------------------------! - ! Checking for convergence or lucky guess. If it did, return, we found the ! - ! solution. Otherwise, constrain the guesses. ! - !---------------------------------------------------------------------------------! - converged = abs(temp-tempa)< toler*temp .and. abs(temp-tempz) < toler*temp - if (funnow == 0. .or. converged) then - converged = .true. - exit fpoloop - elseif (funnow*funa < 0.) then - tempz = temp - funz = funnow - !----- If we are updating zside again, modify aside (Illinois method) ---------! - if (zside) funa=funa * 0.5 - !----- We just updated zside, setting zside to true. --------------------------! - zside = .true. - else - tempa = temp - funa = funnow - !----- If we are updating aside again, modify zside (Illinois method) ---------! - if (.not.zside) funz = funz * 0.5 - !----- We just updated aside, setting zside to false --------------------------! - zside = .false. - end if - - end do fpoloop - - end if - - if (.not. converged) call abort_run('Failed finding equilibrium, I gave up!' & - ,'thil2tqliq','rthrm.f90') - return -end subroutine thil2tqliq -!==========================================================================================! -!==========================================================================================! diff --git a/BRAMS/src/core/rtimh.f90 b/BRAMS/src/core/rtimh.f90 index 3473215db..c9355a990 100644 --- a/BRAMS/src/core/rtimh.f90 +++ b/BRAMS/src/core/rtimh.f90 @@ -68,7 +68,7 @@ subroutine timestep() use advect_kit , only : calc_advec ! ! sub-routine use mem_mass , only : iexev & ! intent(in) , imassflx ! ! intent(in) - + use mem_mnt_advec , only : iadvec ! ! intent(in) implicit none !----- Local variables. ----------------------------------------------------------------! real :: t1 @@ -295,7 +295,12 @@ subroutine timestep() ! Thermodynamic advection. ! !---------------------------------------------------------------------------------------! t1 = cputime(w1) - call advectc('T',mzp,mxp,myp,ia,iz,ja,jz,izu,jzv,mynum) + select case (iadvec) + case (1) + call advectc('T',mzp,mxp,myp,ia,iz,ja,jz,izu,jzv,mynum) + case (2) + call radvc_mnt_driver(mzp,mxp,myp,ia,iz,ja,jz,mynum) + end select if (acct) call acctimes('accu',19,'ADVECTs',t1,w1) !---------------------------------------------------------------------------------------! @@ -606,15 +611,16 @@ end subroutine acctimes !==========================================================================================! ! This subroutine will update the lateral boundary conditions. ! !------------------------------------------------------------------------------------------! -subroutine mpilbc_driver(action,istflag) +subroutine mpilbc_driver(action,izzflag) use node_mod, only : ipara ! ! intent(in) use mem_grid, only : ngrid ! ! intent(in) implicit none !----- Arguments. ----------------------------------------------------------------------! character(len=*), intent(in) :: action - integer , intent(in) :: istflag + integer , intent(in) :: izzflag !----- Local variables. ----------------------------------------------------------------! integer :: ist + integer :: iadv !---------------------------------------------------------------------------------------! @@ -675,12 +681,12 @@ subroutine mpilbc_driver(action,istflag) ! Send staggered lateral conditions. Here we also use the flag telling which ! ! field should be exchanged. ! !------------------------------------------------------------------------------------! - call node_sendst(istflag) + call node_sendst(izzflag) !------------------------------------------------------------------------------------! ! If it is the first grid, check whether we need to exchange cyclic conditions. ! !------------------------------------------------------------------------------------! - if (ngrid == 1) call node_sendcyclic(istflag) + if (ngrid == 1) call node_sendcyclic(izzflag) !------------------------------------------------------------------------------------! case ('getst') @@ -688,12 +694,12 @@ subroutine mpilbc_driver(action,istflag) ! Get staggered lateral conditions. Here we also use the flag telling which ! ! field should be exchanged. ! !------------------------------------------------------------------------------------! - call node_getst(istflag) + call node_getst(izzflag) !------------------------------------------------------------------------------------! ! If it is the first grid, check whether we need to exchange cyclic conditions. ! !------------------------------------------------------------------------------------! - if (ngrid == 1) call node_getcyclic(istflag) + if (ngrid == 1) call node_getcyclic(izzflag) !------------------------------------------------------------------------------------! case ('fullst') @@ -701,8 +707,8 @@ subroutine mpilbc_driver(action,istflag) ! Full exchange of staggered lateral conditions. Here we also use the flag ! ! telling which field should be exchanged. ! !------------------------------------------------------------------------------------! - call node_sendst(istflag) - call node_getst (istflag) + call node_sendst(izzflag) + call node_getst (izzflag) !------------------------------------------------------------------------------------! @@ -711,46 +717,63 @@ subroutine mpilbc_driver(action,istflag) ! If it is the first grid, check whether we need to exchange cyclic conditions. ! !------------------------------------------------------------------------------------! if (ngrid == 1) then - call node_sendcyclic(istflag) - call node_getcyclic(istflag) + call node_sendcyclic(izzflag) + call node_getcyclic(izzflag) end if !------------------------------------------------------------------------------------! - case ('ultimate') + case ('sendadv') + !------------------------------------------------------------------------------------! - ! This is the "ultimate" exchange of boundary conditions. Both thermodynamic ! - ! and staggered grids are exchanged, and all possible flags are used for the ! - ! staggered exchange. This should be used only for debugging purposes, as it slows ! - ! down the run considerably. ! + ! Send the advection boundary conditions variables. ! !------------------------------------------------------------------------------------! - - - - !---- Exchange thermodynamic lateral conditions. ------------------------------------! - call node_sendlbc() - call node_getlbc() + select case (izzflag) + case (0) + !----- Send most variables (iaflag from 1 to 4). ---------------------------------! + do iadv=1,4 + call node_sendadv(iadv) + end do + case default + !----- Send only variabes corresponding to izzflag. ------------------------------! + call node_sendadv(izzflag) + end select !------------------------------------------------------------------------------------! + case ('getadv') - - !---- Exchange staggered lateral conditions. ----------------------------------------! - do ist=2,6 - call node_sendst(ist) - call node_getst (ist) - end do + !------------------------------------------------------------------------------------! + ! Get the advection boundary conditions variables. ! + !------------------------------------------------------------------------------------! + select case (izzflag) + case (0) + !----- Get most variables (iaflag from 1 to 4). ----------------------------------! + do iadv=1,4 + call node_getadv(iadv) + end do + case default + !----- Get only variabes corresponding to izzflag. -------------------------------! + call node_getadv(izzflag) + end select !------------------------------------------------------------------------------------! - + case ('fulladv') !------------------------------------------------------------------------------------! - ! If it is the first grid, check whether we need to exchange cyclic conditions. ! + ! Full exchange of advection lateral conditions. Here we also use the flag ! + ! telling which field should be exchanged. ! !------------------------------------------------------------------------------------! - if (ngrid == 1) then - do ist=1,6 - call node_sendcyclic(ist) - call node_getcyclic(ist) - end do - end if + select case (izzflag) + case (0) + !----- Get most variables (iaflag from 1 to 4). ----------------------------------! + do iadv=1,4 + call node_sendadv(iadv) + call node_getadv (iadv) + end do + case default + !----- Get only variabes corresponding to izzflag. -------------------------------! + call node_sendadv(izzflag) + call node_getadv (izzflag) + end select !------------------------------------------------------------------------------------! end select diff --git a/BRAMS/src/cuparm/grell_coms.f90 b/BRAMS/src/cuparm/grell_coms.f90 index feb619f5f..baa7e340d 100644 --- a/BRAMS/src/cuparm/grell_coms.f90 +++ b/BRAMS/src/cuparm/grell_coms.f90 @@ -112,29 +112,29 @@ module grell_coms ! These variables are parameters for various Grell's computation ! !----------------------------------------------------------------------------------------! !------ Minimum diameter for clouds to develop downdrafts and rain ----------------------! - real , parameter :: min_down_radius = 900. + real , parameter :: min_down_radius = 3000. !------ Epsilon is the ratio between reference downdraft and updraft mass fluxes --------! - real , parameter :: edtmax = .95 ! Upper bound - real , parameter :: edtmin = .20 ! Lower bound + real , parameter :: edtmax = .99 ! Upper bound + real , parameter :: edtmin = .01 ! Lower bound !------ Maximum acceptable PBL height ---------------------------------------------------! - real , parameter :: pblhmax = 3000. + real , parameter :: pblhmax = 3000. - !------ Minimum cloud mixing ratio to consider the layer wet ----------------------------! - real , parameter :: rcpmin = 1.e-5 + !------ Minimum cloud mixing ratio to consider the layer wet [kg/kg] --------------------! + real , parameter :: rcpmin = 1.e-5 !------ Height relative to the top above which no downdrafts can occur ------------------! - real , parameter :: relheight_down = 0.6 + real , parameter :: relheight_down = 0.6 !------ Percentage of mass left when hitting the ground ---------------------------------! - real , parameter :: pmass_left = 0.03 + real , parameter :: pmass_left = 0.03 !------ Maximum "leakage" of mass allowed (normalized) ----------------------------------! - real, parameter :: masstol = 1.e-6 + real , parameter :: masstol = 1.e-6 !----- Maximum height that a cloud can ever possibly reach [m] --------------------------! - real, parameter :: zmaxtpse = 18000. + real , parameter :: zmaxtpse = 18000. !----------------------------------------------------------------------------------------! ! Ensemble related variables. acrit and acritt are a look-up table for climatological ! @@ -162,6 +162,21 @@ module grell_coms , 813.0 , 886.0 , 947.0 ,1138.0 ,1377.0 ,1896.0 /) !----------------------------------------------------------------------------------------! + + !----------------------------------------------------------------------------------------! + ! List of maximum and minimum values that are acceptable. ! + !----------------------------------------------------------------------------------------! + real, parameter :: grellmax_zcheck = 9000. ! Maximum height to test [ m] + real, parameter :: grell_lapse_wet = 0.0045 ! Typical lapse rate [ K/m] + real, parameter :: grellmin_t0 = 184. ! Minimum surface temperature [ K] + real, parameter :: grellmax_t0 = 341. ! Maximum surface temperature [ K] + real, parameter :: grellmin_rhv = 0.001 ! Minimum relative humidity [ ---] + real, parameter :: grellmax_rhv = 1.0 ! Maximum relative humidity [ ---] + real, parameter :: grellmin_co2 = 50. ! Minimum CO2 mixing ratio [ µmol/mol] + real, parameter :: grellmax_co2 = 1000. ! Maximum CO2 mixing ratio [ µmol/mol] + !----------------------------------------------------------------------------------------! + + contains !==========================================================================================! !==========================================================================================! @@ -287,6 +302,8 @@ subroutine define_grell_coms(ngrids,nclouds,mmzp,nnqparm,grell_1st,grell_last) return end subroutine define_grell_coms + !=======================================================================================! + !=======================================================================================! +end module grell_coms !==========================================================================================! !==========================================================================================! -end module grell_coms diff --git a/BRAMS/src/cuparm/grell_cupar_aux.f90 b/BRAMS/src/cuparm/grell_cupar_aux.f90 index 04c1d8280..0ed5f2eac 100644 --- a/BRAMS/src/cuparm/grell_cupar_aux.f90 +++ b/BRAMS/src/cuparm/grell_cupar_aux.f90 @@ -185,8 +185,8 @@ end subroutine initial_tend_grell ! is a deep convection call, then it will include the effect of shallow convection, and ! ! make the variables for the case in which no convection happens consistent with this. ! !------------------------------------------------------------------------------------------! -subroutine initial_thermo_grell(m1,dtime,thp,theta,rtp,co2p,pi0,pp,pc,wp,dn0,tkep,rliq & - ,rice,wstd) +subroutine initial_thermo_grell(m1,mgmzp,dtime,thp,theta,rtp,co2p,pi0,pp,pc,wp,dn0,tkep & + ,rliq,rice,wstd) use mem_scratch_grell, only : & dco2dt & ! intent(in) - Total CO2 mixing ratio tendency [ ppm/s] @@ -222,6 +222,7 @@ subroutine initial_thermo_grell(m1,dtime,thp,theta,rtp,co2p,pi0,pp,pc,wp,dn0,tke ,qicesur & ! intent(out) - Sfc. ice mixing ratio [ kg/kg] ,rho0 & ! intent(out) - Density [ kg/m³] ,rho & ! intent(out) - Density with forcing [ kg/m³] + ,rhosur & ! intent(out) - Sfc. density [ kg/m³] ,t0 & ! intent(out) - Current Temperature [ K] ,t & ! intent(out) - Forced Temperature [ K] ,tsur & ! intent(out) - Sfc. Temperature [ K] @@ -235,11 +236,7 @@ subroutine initial_thermo_grell(m1,dtime,thp,theta,rtp,co2p,pi0,pp,pc,wp,dn0,tke ,tke & ! intent(out) - Forced Turbulent kinetic energy [ J/kg] ,sigw & ! intent(out) - Vertical velocity standard deviation [ m/s] ,wwind ! ! intent(out) - Mean vertical velocity [ m/s] - use rconstants, only : cp & ! intent(in) - , cpi & ! intent(in) - , cpor & ! intent(in) - , p00 & ! intent(in) - , grav & ! intent(in) + use rconstants, only : grav & ! intent(in) , rdry & ! intent(in) , epi & ! intent(in) , toodry & ! intent(in) @@ -247,46 +244,63 @@ subroutine initial_thermo_grell(m1,dtime,thp,theta,rtp,co2p,pi0,pp,pc,wp,dn0,tke , tkmin ! ! intent(in) !------ External functions -------------------------------------------------------------! - use therm_lib, only: & - rslif & ! Function that finds the saturation mixing ratio - ,thetaeiv & ! Function that finds Thetae_iv - ,thil2temp & ! Function that gives temperature from theta_il, rliq and rice. - ,idealdens ! ! Function that gives the density for ideal gasses - + use therm_lib, only : & + rslif & ! Function that finds the saturation mixing ratio + , thetaeiv & ! Function that finds Thetae_iv + , thil2temp & ! Function that gives temperature from theta_il, rliq and rice. + , thil2tqall & ! Function that finds temperature and condensed phase from thil. + , idealdens & ! Function that gives the density for ideal gasses + , exner2press & ! Function that converts Exner function into pressure + , extheta2temp ! ! Function that finds pot. temp. from Exner and temperature implicit none !------ I/O variables ------------------------------------------------------------------! - integer, intent(in) :: m1 ! Grid dimension [ ---] - real , intent(in) :: dtime ! Time step [ s] - real , intent(in) , dimension(m1) :: thp ! Ice-liquid potential temp. [ K] - real , intent(in) , dimension(m1) :: theta ! Potential temperature [ K] - real , intent(in) , dimension(m1) :: rtp ! Total H2O mixing ratio [ kg/kg] - real , intent(in) , dimension(m1) :: co2p ! Total CO2 mixing ratio [ ppm] - real , intent(in) , dimension(m1) :: pi0 ! Reference Exner function [ J/kg/K] - real , intent(in) , dimension(m1) :: pp ! Current perturbation on pi [ J/kg/K] - real , intent(in) , dimension(m1) :: pc ! Future perturbation on pi [ J/kg/K] - real , intent(in) , dimension(m1) :: dn0 ! Reference density [ kg/m³] - real , intent(in) , dimension(m1) :: wp ! Vertical velocity [ m/s] - real , intent(in) , dimension(m1) :: tkep ! Turbulent kinetic energy [ J/kg] - real , intent(in) , dimension(m1) :: rliq ! Liquid water mixing ratio [ kg/kg] - real , intent(in) , dimension(m1) :: rice ! Ice mixing ratio [ kg/kg] - real , intent(in) , dimension(m1) :: wstd ! Standard deviation of wp [ m/s] + integer, intent(in) :: m1 ! Grid dimension [ ---] + integer, intent(in) :: mgmzp ! Dim. of the scratch arrays [ ---] + real , intent(in) :: dtime ! Time step (convective scale) [ s] + real , intent(in) , dimension(m1) :: thp ! Ice-liquid potential temp. [ K] + real , intent(in) , dimension(m1) :: theta ! Potential temperature [ K] + real , intent(in) , dimension(m1) :: rtp ! Total H2O mixing ratio [ kg/kg] + real , intent(in) , dimension(m1) :: co2p ! Total CO2 mixing ratio [umol/mol] + real , intent(in) , dimension(m1) :: pi0 ! Reference Exner function [ J/kg/K] + real , intent(in) , dimension(m1) :: pp ! Current perturbation on pi [ J/kg/K] + real , intent(in) , dimension(m1) :: pc ! Future perturbation on pi [ J/kg/K] + real , intent(in) , dimension(m1) :: dn0 ! Reference density [ kg/m³] + real , intent(in) , dimension(m1) :: wp ! Vertical velocity [ m/s] + real , intent(in) , dimension(m1) :: tkep ! Turbulent kinetic energy [ J/kg] + real , intent(in) , dimension(m1) :: rliq ! Liquid water mixing ratio [ kg/kg] + real , intent(in) , dimension(m1) :: rice ! Ice mixing ratio [ kg/kg] + real , intent(in) , dimension(m1) :: wstd ! Standard deviation of wp [ m/s] !------ Local variables ----------------------------------------------------------------! - integer :: k,kr ! Counters - real :: dq ! Diff. on vapour mixing ratio [ kg/kg] - real :: qsat ! Sat. mixing ratio (scratch) [ kg/kg] + integer :: k ! Counters [ ---] + integer :: kr ! Counters [ ---] + real :: dq ! Diff. on vapour mixing ratio [ kg/kg] + real :: qsat ! Sat. mixing ratio (scratch) [ kg/kg] + !------ Surface variables, copied to a dummy array because of interface check. ---------! + real , dimension(1) :: z1 ! Height [ m] + real , dimension(1) :: exner1 ! Exner function [ J/kg/K] + real , dimension(1) :: p1 ! Pressure [ Pa] + real , dimension(1) :: thil1 ! Ice-liquid potential temp. [ K] + real , dimension(1) :: qtot1 ! Total water mixing ratio [ kg/kg] + real , dimension(1) :: qliq1 ! Liquid water mixing ratio [ kg/kg] + real , dimension(1) :: qice1 ! Ice mixing ratio [ kg/kg] + real , dimension(1) :: qvap1 ! Vapour mixing ratio [ kg/kg] + real , dimension(1) :: t1 ! Temperature [ K] + real , dimension(1) :: theiv1 ! Equiv. ice vapour pot. temp. [ K] + real , dimension(1) :: co21 ! CO2 mixing ratio [umol/mol] + real , dimension(1) :: rho1 ! Density [ kg/m³] !---------------------------------------------------------------------------------------! do k=1,mkx kr=k+kgoff ![[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[! !------------------------------------------------------------------------------------! - ! Finding the current state variables, including the effect of shallower cumulus ! + ! Find the current state variables, including the effect of shallower cumulus ! ! if that is the case. ! !------------------------------------------------------------------------------------! !------ 1. Exner function -----------------------------------------------------------! exner0(k) = pi0(kr) + pp(kr) !------ 2. Pressure. ----------------------------------------------------------------! - p0(k) = p00*(cpi*exner0(k))**cpor + p0(k) = exner2press(exner0(k)) !------------------------------------------------------------------------------------! ! 3. Temperature and water. ! !------------------------------------------------------------------------------------! @@ -295,23 +309,23 @@ subroutine initial_thermo_grell(m1,dtime,thp,theta,rtp,co2p,pi0,pp,pc,wp,dn0,tke qliq0(k) = max(0.,rliq(kr)) qice0(k) = max(0.,rice(kr)) qvap0(k) = max(toodry,qtot0(k)-qice0(k)-qliq0(k)) - t0(k) = cpi * theta(kr) * exner0(k) + t0(k) = extheta2temp(exner0(k),theta(kr)) !------ 4. Finding the ice-vapour equivalent potential temperature ------------------! - theiv0(k) = thetaeiv(thil0(k),p0(k),t0(k),qvap0(k),qtot0(k),5) + theiv0(k) = thetaeiv(thil0(k),p0(k),t0(k),qvap0(k),qtot0(k)) !------ 5. CO2 mixing ratio. --------------------------------------------------------! co20(k) = co2p(kr) !------ 6. Turbulent kinetic energy [m²/s²] -----------------------------------------! - tke0(k) = tkep(kr) + tke0(k) = tkep(kr) !------ 7. Vertical velocity in terms of pressure, or Lagrangian dp/dt [ Pa/s] ------! - omeg(k) = -grav*dn0(kr)*.5*( wp(kr)+wp(kr-1) ) + omeg(k) = -grav*dn0(kr)*.5*( wp(kr)+wp(kr-1) ) !------ 8. Vertical velocity [m/s], this is staggered, averaging... -----------------! - wwind(k) = 0.5 * (wp(kr)+wp(kr-1)) + wwind(k) = 0.5 * (wp(kr)+wp(kr-1)) !------ 9. Standard-deviation of vertical velocity ----------------------------------! - sigw(k) = max(wstd(kr),sigwmin) + sigw(k) = max(wstd(kr),sigwmin) !------ 10. Air density -------------------------------------------------------------! - rho(k) = idealdens(p0(k),t0(k),qvap0(k),qtot0(k)) + rho(k) = idealdens(p0(k),t0(k),qvap0(k),qtot0(k)) !------------------------------------------------------------------------------------! !]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]! @@ -319,7 +333,7 @@ subroutine initial_thermo_grell(m1,dtime,thp,theta,rtp,co2p,pi0,pp,pc,wp,dn0,tke ![[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[! !------------------------------------------------------------------------------------! - ! Finding what the state variables will be in the next time, assuming no convec- ! + ! Find what the state variables will be in the next time, assuming no convec- ! ! tion at this point (we will call these forced variables). Most variables will be ! ! updated using the tendency, except for the Exner function and diagnostic vari- ! !ables. ! @@ -327,16 +341,16 @@ subroutine initial_thermo_grell(m1,dtime,thp,theta,rtp,co2p,pi0,pp,pc,wp,dn0,tke !------ 1. Exner function pc is the future Exner perturbation. ----------------------! exner(k) = pi0(kr) + pc(kr) !------ 2. Pressure -----------------------------------------------------------------! - p(k) = p00*(cpi*exner(k))**cpor + p(k) = exner2press(exner(k)) !------ 3. Ice-liquid potential temperature, with the tendency ----------------------! thil(k) = thp(kr) + dthildt(k)*dtime !------ 4. Total mixing ratio, with the tendency ------------------------------------! qtot(k) = max(toodry,rtp(kr) + dqtotdt(k) * dtime) - !------ 5. Finding the equilibrium state. Temperature 1st guess is simply t0 --------! + !------ 5. Find the equilibrium state. Temperature 1st guess is simply t0. ----------! t(k) = t0(k) call thil2tqall(thil(k),exner(k),p(k),qtot(k),qliq(k),qice(k),t(k),qvap(k),qsat) !------ 6. Finding the ice-vapour equivalent potential temperature ------------------! - theiv(k) = thetaeiv(thil(k),p(k),t(k),qvap(k),qtot(k),6) + theiv(k) = thetaeiv(thil(k),p(k),t(k),qvap(k),qtot(k)) !------ 7. CO2 mixing ratio ---------------------------------------------------------! co2(k) = co2p(kr) + dco2dt(k) * dtime !------ 8. Turbulent kinetic energy -------------------------------------------------! @@ -347,41 +361,68 @@ subroutine initial_thermo_grell(m1,dtime,thp,theta,rtp,co2p,pi0,pp,pc,wp,dn0,tke !]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]! end do - + + ![[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[! !---------------------------------------------------------------------------------------! - ! Computing the surface variables. The only one that will be truly different is the ! + ! Compute the surface variables. The only one that will be truly different is the ! ! Exner function (and consequently, pressure). The other values will be based on the ! ! level above. This is going to be just a boundary condition, so they will directly ! ! affect the parametrisation. ! !---------------------------------------------------------------------------------------! + !----- 0. Height, always 0. ------------------------------------------------------------! + z1(1) = 0. !----- 1. Exner function ---------------------------------------------------------------! exnersur = sqrt((pp(lpw-1)+pi0(lpw-1))*(pp(lpw)+pi0(lpw))) + exner1(1) = exnersur !----- 2. Pressure ---------------------------------------------------------------------! - psur = p00*(cpi*exnersur)**cpor + psur = exner2press(exnersur) + p1(1) = psur !----- 3. Ice liquid potential temperature ---------------------------------------------! thilsur = thp(lpw) + thil1(1) = thilsur !----- 4. Total mixing ratio -----------------------------------------------------------! qtotsur = max(toodry,rtp(lpw)) + qtot1(1) = qtotsur !----- 5. Liquid water mixing ratio ----------------------------------------------------! qliqsur = max(0.,rliq(lpw)) + qliq1(1) = qliqsur !----- 6. Ice mixing ratio -------------------------------------------------------------! qicesur = max(0.,rice(lpw)) + qice1(1) = qicesur !----- 7. Vapour mixing ratio ----------------------------------------------------------! qvapsur = max(toodry,qtotsur-qliqsur-qicesur) + qvap1(1) = qvapsur !----- 7. Temperature ------------------------------------------------------------------! - tsur = cpi*theta(lpw)*exnersur + tsur = extheta2temp(exnersur,theta(lpw)) + t1(1) = tsur !----- 8. Ice-vapour equivalent potential temperature ----------------------------------! - theivsur = thetaeiv(thilsur,psur,tsur,qvapsur,qtotsur,7) + theivsur = thetaeiv(thilsur,psur,tsur,qvapsur,qtotsur) + theiv1(1) = theivsur !----- 9. CO2 mixing ratio -------------------------------------------------------------! co2sur = co2p(lpw) + co21(1) = co2sur + !----- 10. Air density -----------------------------------------------------------------! + rhosur = idealdens(psur,tsur,qvapsur,qtotsur) + rho1(1) = rhosur !---------------------------------------------------------------------------------------! !]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]! + !---------------------------------------------------------------------------------------! + ! Check the profiles we will use. ! + !---------------------------------------------------------------------------------------! + call grell_sanity_check(mkx,mgmzp,z,p0,exner0,theiv0,thil0,t0,qtot0,qvap0,qliq0 & + ,qice0,co20,rho0,'thermo_zero') + call grell_sanity_check(mkx,mgmzp,z,p,exner,theiv,thil,t,qtot,qvap,qliq,qice,co2 & + ,rho,'thermo_extrap') + call grell_sanity_check(1,1,z1,p1,exner1,theiv1,thil1,t1,qtot1,qvap1,qliq1,qice1,co21 & + ,rho1,'thermo_surface') + !---------------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------------! - ! Finding the integrated moisture convergence. This is done outside the loop so we ! + ! Find the integrated moisture convergence. This is done outside the loop so we ! ! can use vapour mixing ratio at level (k-1) and (k+1). ! !---------------------------------------------------------------------------------------! mconv=0. @@ -432,7 +473,7 @@ subroutine initial_winds_grell(prec_cld,m1,m2,m3,i,j,jdim,last_dnmf,ua,va,prev_d real , dimension(m2,m3) , intent(in) :: last_dnmf ! Last time downdraft real , dimension(m1,m2,m3) , intent(in) :: ua ! Zonal wind real , dimension(m1,m2,m3) , intent(in) :: va ! Meridional wind - real , intent(inout) :: prev_dnmf ! Previous downdraft + real , dimension(1) , intent(inout) :: prev_dnmf ! Previous downdraft !------ Local variables ----------------------------------------------------------------! integer :: k ! Counter for current Grell level integer :: kr ! Counter for corresponding BRAMS level @@ -440,7 +481,7 @@ subroutine initial_winds_grell(prec_cld,m1,m2,m3,i,j,jdim,last_dnmf,ua,va,prev_d !------ Initializing scalars -----------------------------------------------------------! - prev_dnmf = last_dnmf(i,j) + prev_dnmf(1) = last_dnmf(i,j) !---------------------------------------------------------------------------------------! ! Transferring the values from BRAMS to Grell's levels, remembering that Grell's ! ! grid goes from 1 to m1-1. ! @@ -981,3 +1022,168 @@ subroutine grell_massflx_stats(m1,icld,itest,dti,maxens_dyn,maxens_lsf,maxens_ef end subroutine grell_massflx_stats !==========================================================================================! !==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +! This sub-routine checks whether the partial results in the cumulus parametrisation ! +! make sense or not. ! +!------------------------------------------------------------------------------------------! +subroutine grell_sanity_check(mkx,mgmzp,z,press,exner,theiv,thil,t,qtot,qvap,qliq,qice & + ,co2,rho,which) + use grell_coms, only : grellmax_zcheck & ! intent(in) + , grell_lapse_wet & ! intent(in) + , grellmin_t0 & ! intent(in) + , grellmax_t0 & ! intent(in) + , grellmin_rhv & ! intent(in) + , grellmax_rhv & ! intent(in) + , grellmin_co2 & ! intent(in) + , grellmax_co2 ! ! intent(in) + use therm_lib , only : extemp2theta & ! intent(in) + , eslif & ! intent(in) + , thetaeivs ! ! intent(in) + use rconstants, only : ep & ! intent(in) + , t00 & ! intent(in) + , gocp ! ! intent(in) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: mkx ! Number of layers + integer , intent(in) :: mgmzp ! Array dimensions + real , dimension(mgmzp), intent(in) :: z ! Height [ m] + real , dimension(mgmzp), intent(in) :: press ! Pressure [ Pa] + real , dimension(mgmzp), intent(in) :: exner ! Exner function [ J/kg/K] + real , dimension(mgmzp), intent(in) :: theiv ! Equiv. pot. temp. [ K] + real , dimension(mgmzp), intent(in) :: thil ! I.L. Pot. temp. [ K] + real , dimension(mgmzp), intent(in) :: t ! Temperature [ K] + real , dimension(mgmzp), intent(in) :: qtot ! Total mixing ratio [ kg/kg] + real , dimension(mgmzp), intent(in) :: qvap ! Vapour mixing ratio [ kg/kg] + real , dimension(mgmzp), intent(in) :: qliq ! Liquid mixing ratio [ kg/kg] + real , dimension(mgmzp), intent(in) :: qice ! Ice mixing ratio [ kg/kg] + real , dimension(mgmzp), intent(in) :: co2 ! CO2 mixing ratio [µmol/mol] + real , dimension(mgmzp), intent(in) :: rho ! Air density [ kg/m3] + character(len=*) , intent(in) :: which ! Which call? + !----- Local variables. ----------------------------------------------------------------! + real :: grellmin_t ! Minimum temperature [ K] + real :: grellmax_t ! Maximum temperature [ K] + real :: grellmin_thil ! Minimum ice-liquid potential temperature [ K] + real :: grellmax_thil ! Maximum ice-liquid potential temperature [ K] + real :: grellmin_theiv ! Minimum ice-vapour equivalent pot. temperature [ K] + real :: grellmax_theiv ! Maximum ice-vapour equivalent pot. temperature [ K] + real :: grellmin_pvap ! Minimum vapour pressure [ Pa] + real :: grellmax_pvap ! Maximum vapour pressure [ Pa] + real :: grellmin_qvap ! Minimum vapour mixing ratio [ kg/kg] + real :: grellmax_qvap ! Maximum vapour mixing ratio [ kg/kg] + real :: grellmin_qtot ! Minimum total mixing ratio [ kg/kg] + real :: grellmax_qtot ! Maximum total mixing ratio [ kg/kg] + logical :: everything_fine ! This will become false if anything looks wrong [ T|F] + integer :: k ! Counter [ --] + integer :: l ! Counter [ --] + integer :: m ! Counter [ --] + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! Let's be optimistic and assume that everything is fine. ! + !---------------------------------------------------------------------------------------! + everything_fine = .true. + !---------------------------------------------------------------------------------------! + + !----- Loop over all layers and check for problems. ------------------------------------! + checkloop: do k = 1,mkx + if (z(k) > grellmax_zcheck) exit checkloop + + !------------------------------------------------------------------------------------! + ! Find derived bounds. ! + !------------------------------------------------------------------------------------! + !----- Temperature. -----------------------------------------------------------------! + grellmin_t = grellmin_t0 - gocp * z(k) + grellmax_t = grellmax_t0 - grell_lapse_wet * z(k) + everything_fine = t(k) >= grellmin_t .and. t(k) <= grellmax_t + !----- Vapour pressure. -------------------------------------------------------------! + grellmin_pvap = grellmin_rhv * eslif(grellmin_t) + grellmin_pvap = grellmax_rhv * eslif(grellmax_t) + !----- Vapour mixing ratio. ---------------------------------------------------------! + grellmin_qvap = ep * grellmin_pvap / (press(k) - grellmin_pvap) + grellmax_qvap = ep * grellmax_pvap / (press(k) - grellmax_pvap) + everything_fine = qvap(k) >= grellmin_qvap .and. qvap(k) <= grellmax_qvap + !----- Total mixing ratio. Minimum is unsaturated, maximum assumed to 2*qvap... ----! + grellmin_qtot = grellmin_qvap + grellmax_qtot = grellmax_qvap * 2.0 + everything_fine = qtot(k) >= grellmin_qtot .and. qtot(k) <= grellmax_qtot + !----- Ice-liquid potential temperature. --------------------------------------------! + grellmin_thil = extemp2theta(exner(k),grellmin_t) + grellmax_thil = extemp2theta(exner(k),grellmax_t) + everything_fine = thil(k) >= grellmin_thil .and. thil(k) <= grellmax_thil + !----- Ice-vapour equivalent potential temperature. ---------------------------------! + grellmin_theiv = grellmin_thil + grellmax_theiv = thetaeivs(grellmax_thil,grellmax_t,grellmax_qvap,grellmax_qvap,0.) + everything_fine = theiv(k) >= grellmin_theiv .and. theiv(k) <= grellmax_theiv + !----- CO2 mixing ratio. ------------------------------------------------------------! + everything_fine = co2(k) >= grellmin_co2 .and. co2(k) <= grellmax_co2 + !------------------------------------------------------------------------------------! + + if (.not. everything_fine) then + !---------------------------------------------------------------------------------! + ! This is the problem of being optimistic: more often than not you may be ! + ! disappointed... But hey, don't hate me messenger, I'm just going to print ! + ! this so you can work towards a better model. ! + !---------------------------------------------------------------------------------! + write (unit=*,fmt='(150a)' ) ('-',m=1,169) + write (unit=*,fmt='(3(a,1x))' ) ' -> Event: ',trim(which) & + ,' has unrealistic thermodynamics...' + write (unit=*,fmt='(150a)' ) ('-',m=1,169) + write (unit=*,fmt='(a)' ) ' BOUNDS' + write (unit=*,fmt='(a)' ) '' + write (unit=*,fmt='(a,es12.5)') ' Min TEMP [ degC]: ',grellmin_t - t00 + write (unit=*,fmt='(a,es12.5)') ' Max TEMP [ degC]: ',grellmax_t - t00 + write (unit=*,fmt='(a,es12.5)') ' Min THIL [ K]: ',grellmin_thil + write (unit=*,fmt='(a,es12.5)') ' Max THIL [ K]: ',grellmax_thil + write (unit=*,fmt='(a,es12.5)') ' Min THEIV [ K]: ',grellmin_theiv + write (unit=*,fmt='(a,es12.5)') ' Max THEIV [ K]: ',grellmax_theiv + write (unit=*,fmt='(a,es12.5)') ' Min PVAP [ hPa]: ',grellmin_pvap * 0.01 + write (unit=*,fmt='(a,es12.5)') ' Max PVAP [ hPa]: ',grellmax_pvap * 0.01 + write (unit=*,fmt='(a,es12.5)') ' Min QVAP [ g/kg]: ',grellmin_qvap * 1000. + write (unit=*,fmt='(a,es12.5)') ' Max QVAP [ g/kg]: ',grellmax_qvap * 1000. + write (unit=*,fmt='(a,es12.5)') ' Min QTOT [ g/kg]: ',grellmin_qtot * 1000. + write (unit=*,fmt='(a,es12.5)') ' Max QTOT [ g/kg]: ',grellmax_qtot * 1000. + write (unit=*,fmt='(a,es12.5)') ' Min CO2 [umol/mol]: ',grellmin_co2 + write (unit=*,fmt='(a,es12.5)') ' Max CO2 [umol/mol]: ',grellmax_co2 + write (unit=*,fmt='(a)' ) '' + write (unit=*,fmt='(150a)' ) ('-',m=1,169) + write (unit=*,fmt='(13(a,1x))') ' LAYER',' HEIGHT',' PRESSURE' & + ,' EXNER',' TEMP',' THETA_IL' & + ,' THETAT_EIV',' QVAP',' QLIQ' & + ,' QICE',' QTOT',' DENSITY' & + ,' CO2' + write (unit=*,fmt='(13(a,1x))') ' ---',' m',' hPa' & + ,' J/kg/K',' degC',' K' & + ,' K',' g/kg',' g/kg' & + ,' g/kg',' g/kg',' kg/m3' & + ,' umol/mol' + write (unit=*,fmt='(150a)' ) ('-',m=1,169) + do l=mkx,1,-1 + write (unit=*,fmt='(i12,1x,12(f12.2))') & + l,z(l),press(l)*0.01,exner(l),t(l)-t00,thil(l) & + ,theiv(l),qvap(l)*1000.,qliq(l)*1000. & + ,qice(l)*1000.,qtot(l)*1000.,rho(l),co2(l) + end do + write (unit=*,fmt='(150a)' ) ('-',m=1,169) + write (unit=*,fmt='(a)' ) '' + call brams_fail_whale() + call abort_run('Unreasonable thermodynamic variables','grell_sanity_check' & + ,'grell_cupar_aux.f90') + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + end do checkloop + !---------------------------------------------------------------------------------------! + + return +end subroutine grell_sanity_check +!==========================================================================================! +!==========================================================================================! diff --git a/BRAMS/src/cuparm/grell_cupar_downdraft.f90 b/BRAMS/src/cuparm/grell_cupar_downdraft.f90 index b815c98eb..7ccf27529 100644 --- a/BRAMS/src/cuparm/grell_cupar_downdraft.f90 +++ b/BRAMS/src/cuparm/grell_cupar_downdraft.f90 @@ -285,8 +285,16 @@ subroutine grell_most_thermo_downdraft(mkx,mgmzp,klod,qtot,co2,mentrd_rate,cdd,p ,etad_cld,dzd_cld,thild_cld,td_cld,qtotd_cld & ,qvapd_cld,qliqd_cld,qiced_cld,qsatd_cld,co2d_cld & ,rhod_cld,dbyd,pwd_cld,pwev,ierr) - use rconstants, only: epi,rdry,t00,cpi,toodry,toowet - use therm_lib , only: thetaeiv2thil,toler,maxfpo,idealdens + use rconstants, only : epi & ! intent(in) + , rdry & ! intent(in) + , t00 & ! intent(in) + , toodry & ! intent(in) + , toowet ! ! intent(in) + use therm_lib , only : thetaeiv2thil & ! subroutine + , thil2tqall & ! subroutine + , toler & ! intent(in) + , maxfpo & ! intent(in) + , idealdens ! ! function implicit none integer , intent(in) :: mkx, mgmzp ! Grid dimesnsions @@ -299,7 +307,7 @@ subroutine grell_most_thermo_downdraft(mkx,mgmzp,klod,qtot,co2,mentrd_rate,cdd,p real, dimension(mgmzp), intent(in) :: mentrd_rate ! Entrainment rate; [ 1/m] real, dimension(mgmzp), intent(in) :: cdd ! Detrainment function; [ 1/m] !----- Variables at cloud levels -------------------------------------------------------! - real, dimension(mgmzp), intent(in) :: p_cup ! Pressure @ cloud levels [ 1/m] + real, dimension(mgmzp), intent(in) :: p_cup ! Pressure @ cloud levels [ Pa] real, dimension(mgmzp), intent(in) :: exner_cup ! Exner fctn. @ cloud lev. [J/kg/K] real, dimension(mgmzp), intent(in) :: thil_cup ! Theta_il [ K] real, dimension(mgmzp), intent(in) :: t_cup ! Temperature [ K] diff --git a/BRAMS/src/cuparm/grell_cupar_driver.f90 b/BRAMS/src/cuparm/grell_cupar_driver.f90 index 2fd1c41b2..8ed6c24bf 100644 --- a/BRAMS/src/cuparm/grell_cupar_driver.f90 +++ b/BRAMS/src/cuparm/grell_cupar_driver.f90 @@ -94,9 +94,9 @@ subroutine grell_cupar_driver(cldd,clds) ! 4. We now compute the dynamic control, which will determine the characteristic ! ! mass flux for each Grell cumulus cloud. ! !---------------------------------------------------------------------------------! - call grell_cupar_dynamic(cldd,clds,nclouds,dtlt,maxens_cap,maxens_eff,maxens_lsf & - ,maxens_dyn,mgmzp,closure_type,comp_modif_thermo & - ,prec_cld,cld2prec,mynum,i,j) + call grell_cupar_dynamic(cldd,clds,nclouds,confrq,maxens_cap,maxens_eff & + ,maxens_lsf,maxens_dyn,mgmzp,closure_type & + ,comp_modif_thermo,prec_cld,cld2prec,mynum,i,j) !---------------------------------------------------------------------------------! ! 5. We now go through the cloud sizes again, to compute the feedback to the ! @@ -158,6 +158,7 @@ subroutine grell_cupar_initial(i,j,confrqd) , vctr18 ! ! Scratch, CO2 tendency. !----- The following module variables are supposed to be sub-routines. -----------------! use mem_scratch_grell, only : zero_scratch_grell ! ! Flushes scratch variables to zero. + use grell_coms , only : mgmzp ! ! intent(in) !---------------------------------------------------------------------------------------! implicit none @@ -256,7 +257,7 @@ subroutine grell_cupar_initial(i,j,confrqd) ! the future values in case convection does not happen (previous values plus the ! ! large-scale forcing). ! !---------------------------------------------------------------------------------------! - call initial_thermo_grell(mzp,dtlt , basic_g(ngrid)%thp (:,i,j) & + call initial_thermo_grell(mzp,mgmzp,confrqd , basic_g(ngrid)%thp (:,i,j) & , basic_g(ngrid)%theta (:,i,j), basic_g(ngrid)%rtp (:,i,j) & , vctr8 (1:mzp), basic_g(ngrid)%pi0 (:,i,j) & , basic_g(ngrid)%pp (:,i,j), basic_g(ngrid)%pc (:,i,j) & diff --git a/BRAMS/src/cuparm/grell_cupar_dynamic.f90 b/BRAMS/src/cuparm/grell_cupar_dynamic.f90 index d93fb5473..14dbb367b 100644 --- a/BRAMS/src/cuparm/grell_cupar_dynamic.f90 +++ b/BRAMS/src/cuparm/grell_cupar_dynamic.f90 @@ -21,7 +21,7 @@ subroutine grell_cupar_dynamic(cldd,clds,nclouds,dtime,maxens_cap,maxens_eff,max ,cld2prec,mynum,i,j) use mem_ensemble , only : ensemble_vars & ! structure , ensemble_e ! ! intent(inout) - + use grid_dims , only : str_len ! ! intent(in) use mem_scratch_grell, only : & co2 & ! intent(in) - CO2 mixing ratio with forcing. [ ppm] ,co2sur & ! intent(in) - surface CO2 mixing ratio [ ppm] @@ -117,7 +117,7 @@ subroutine grell_cupar_dynamic(cldd,clds,nclouds,dtime,maxens_cap,maxens_eff,max ,x_thilu_cld & ! intent(out) - Ice-liquid potential temperature [ K] ,zero_scratch_grell ! ! subroutine - Resets scratch variables to zero. use rconstants, only: toodry - + use therm_lib , only : thil2tqall implicit none !---------------------------------------------------------------------------------------! ! List of arguments ! @@ -190,6 +190,8 @@ subroutine grell_cupar_dynamic(cldd,clds,nclouds,dtime,maxens_cap,maxens_eff,max integer :: x_ktop ! Cloud top level logical :: x_comp_dn! Downdraft flag real :: x_qsat + !----- Flag for the sanity check. ------------------------------------------------------! + character(len=str_len) :: which ! Flag to locate sanity check !---------------------------------------------------------------------------------------! !---------------------------------------------------------------------------------------! ! Miscellaneous parameters ! @@ -216,7 +218,7 @@ subroutine grell_cupar_dynamic(cldd,clds,nclouds,dtime,maxens_cap,maxens_eff,max call zero_scratch_grell(1) !---------------------------------------------------------------------------------! - ! 1. Copying the variables stored at the ensemble structure to temporary arrays. ! + ! 1. Copy the variables stored at the ensemble structure to temporary arrays. ! !---------------------------------------------------------------------------------! !----- ierr and klnb have the cloud index because of the dyn. control ensemble. --! ierr (icld) = ensemble_e(icld)%ierr_cap (icap) @@ -322,8 +324,9 @@ subroutine grell_cupar_dynamic(cldd,clds,nclouds,dtime,maxens_cap,maxens_eff,max modif_comp_if: if (comp_modif_thermo .and. & ensemble_e(icld)%ierr_cap(icap) == 0) then !------------------------------------------------------------------! - ! 5b. Compute the modified structure, finding the consistent set ! - ! and then interpolating them to the cloud levels. ! + ! 5b. Compute the modified structure: find the consistent set then ! + ! interpolate them to the cloud levels, and check whether the ! + ! profile makes sense. ! !------------------------------------------------------------------! do k=1,mkx x_t(k) = t (k) @@ -337,10 +340,16 @@ subroutine grell_cupar_dynamic(cldd,clds,nclouds,dtime,maxens_cap,maxens_eff,max ,x_qtot_cup,x_qvap_cup,x_qliq_cup & ,x_qice_cup,x_qsat_cup,x_co2_cup,x_rho_cup & ,x_theiv_cup,x_theivs_cup) + write (which,fmt='(3(a,i4.4))') 'nudge_environment_icap=',icap & + ,'_icld=',icld,'_jcld=',jcld + call grell_sanity_check(mkx,mgmzp,z_cup,x_p_cup,x_exner_cup & + ,x_theiv_cup,x_thil_cup,x_t_cup,x_qtot_cup & + ,x_qvap_cup,x_qliq_cup,x_qice_cup,x_co2_cup & + ,x_rho_cup,which) !------------------------------------------------------------------! - ! 5c. Finding the updraft thermodynamics between the updraft ! - ! origin and the level of free convection. ! + ! 5c. Find the updraft thermodynamics between the updraft origin ! + ! and the level of free convection. ! !------------------------------------------------------------------! call grell_buoy_below_lfc(mkx,mgmzp,klou(icld),klfc(icld) & ,x_exner_cup,x_p_cup,x_theiv_cup & @@ -360,7 +369,8 @@ subroutine grell_cupar_dynamic(cldd,clds,nclouds,dtime,maxens_cap,maxens_eff,max ,x_theivu_cld) !------------------------------------------------------------------! - ! 5e. Getting the updraft moisture profile ! + ! 5e. Get the updraft moisture profile, and check whether it makes ! + ! sense or not. ! !------------------------------------------------------------------! call grell_most_thermo_updraft(prec_cld(icld),.false.,mkx,mgmzp & ,klfc(icld),ktop(icld),cld2prec,cdu & @@ -375,6 +385,12 @@ subroutine grell_cupar_dynamic(cldd,clds,nclouds,dtime,maxens_cap,maxens_eff,max ,x_co2u_cld,x_rhou_cld,x_dbyu & ,x_pwu_cld,x_pwav,x_klnb,x_ktop & ,x_ierr) + write (which,fmt='(3(a,i4.4))') 'nudge_updraft_icap=',icap & + ,'_icld=',icld,'_jcld=',jcld + call grell_sanity_check(mkx,mgmzp,z_cup,x_p_cup,x_exner_cup & + ,x_theivu_cld,x_thilu_cld,x_tu_cld & + ,x_qtotu_cld,x_qvapu_cld,x_qliqu_cld & + ,x_qiceu_cld,x_co2u_cld,x_rhou_cld,which) !------------------------------------------------------------------! ! 5f. Recalculating the updraft cloud work ! @@ -408,9 +424,15 @@ subroutine grell_cupar_dynamic(cldd,clds,nclouds,dtime,maxens_cap,maxens_eff,max ,x_qsatd_cld,x_co2d_cld & ,x_rhod_cld,x_dbyd,x_pwd_cld & ,x_pwev,x_ierr) + write (which,fmt='(3(a,i4.4))') 'nudge_downdraft_icap=',icap & + ,'_icld=',icld,'_jcld=',jcld + call grell_sanity_check(mkx,mgmzp,z_cup,x_p_cup,x_exner_cup & + ,x_theivd_cld,x_thild_cld,x_td_cld & + ,x_qtotd_cld,x_qvapd_cld,x_qliqd_cld & + ,x_qiced_cld,x_co2d_cld,x_rhod_cld,which) !---------------------------------------------------------------! - ! 5i. Computing cloud work function associated with downdrafts. ! + ! 5i. Compute cloud work function associated with downdrafts. ! !---------------------------------------------------------------! call grell_cldwork_downdraft(mkx,mgmzp,klod,x_dbyd,dzd_cld & ,etad_cld,x_aad) @@ -512,7 +534,7 @@ subroutine grell_cupar_dynamic(cldd,clds,nclouds,dtime,maxens_cap,maxens_eff,max ierr(icld) = ensemble_e(icld)%ierr_cap(icap) pwav(icld) = ensemble_e(icld)%pwav_cap(icap) pwev(icld) = ensemble_e(icld)%pwev_cap(icap) - prev_dnmf(icld) = ensemble_e(icld)%prev_dnmf + prev_dnmf(icld) = ensemble_e(icld)%prev_dnmf(1) !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! @@ -926,8 +948,12 @@ subroutine grell_grell_solver(nclouds,cldd,clds,dtime,fac,aatot0,aatot,mfke,ierr if (nsolv == 0) exit queq_loop !----- Allocate some vectors we need for solving the linear system. -----------------! - allocate(kke(nsolv,nsolv),diagkke(nsolv),mfo(nsolv),mb(nsolv),cldidx(nsolv)) - + allocate(kke (nsolv,nsolv)) + allocate(diagkke (nsolv)) + allocate(mfo (nsolv)) + allocate(mb (nsolv)) + allocate(cldidx (nsolv)) + !----- Store the actual cloud number of the clouds that exist. ----------------------! cldidx = pack(cloud,okcld) @@ -970,7 +996,12 @@ subroutine grell_grell_solver(nclouds,cldd,clds,dtime,fac,aatot0,aatot,mfke,ierr ! The matrix is singular or almost singular, so we cannot solve these clouds. ! ! We can quit this routine after freeing the allocated arrays. ! !---------------------------------------------------------------------------------! - deallocate(kke,mfo,mb,cldidx) + deallocate(kke ) + deallocate(diagkke) + deallocate(mfo ) + deallocate(mb ) + deallocate(cldidx ) + !---------------------------------------------------------------------------------! exit queq_loop elseif (any(mb < 0.) .or. any(diagkke == 0.)) then !---------------------------------------------------------------------------------! @@ -985,7 +1016,12 @@ subroutine grell_grell_solver(nclouds,cldd,clds,dtime,fac,aatot0,aatot,mfke,ierr end if end do !----- Free memory so it will be ready to be allocated again next time. ----------! - deallocate(kke,diagkke,mfo,mb,cldidx) + deallocate(kke ) + deallocate(diagkke) + deallocate(mfo ) + deallocate(mb ) + deallocate(cldidx ) + !---------------------------------------------------------------------------------! else !---------------------------------------------------------------------------------! ! All mass flux terms are zero or positive, we are all set. Simply copy the ! @@ -998,7 +1034,12 @@ subroutine grell_grell_solver(nclouds,cldd,clds,dtime,fac,aatot0,aatot,mfke,ierr upmx(jcld) = max(0.,mfo(jsol) / kke(jsol,jsol)) end do !----- Free memory before leaving the subroutine. --------------------------------! - deallocate(kke,diagkke,mfo,mb,cldidx) + deallocate(kke ) + deallocate(diagkke) + deallocate(mfo ) + deallocate(mb ) + deallocate(cldidx ) + !---------------------------------------------------------------------------------! exit queq_loop end if @@ -1103,8 +1144,12 @@ subroutine grell_arakschu_solver(nclouds,cldd,clds,mgmzp,dtime,p_cup,clim,whlev, if (nsolv == 0) exit queq_loop !----- Allocate some vectors we need for solving the linear system. -----------------! - allocate(kke(nsolv,nsolv),diagkke(nsolv),mfo(nsolv),mb(nsolv),cldidx(nsolv)) - + allocate(kke (nsolv,nsolv)) + allocate(diagkke (nsolv)) + allocate(mfo (nsolv)) + allocate(mb (nsolv)) + allocate(cldidx (nsolv)) + !----- Store the actual cloud number of those clouds cldidx = pack(cloud,okcld) @@ -1170,7 +1215,11 @@ subroutine grell_arakschu_solver(nclouds,cldd,clds,mgmzp,dtime,p_cup,clim,whlev, ! The matrix is singular or almost singular, so we cannot solve these clouds. ! ! We can quit this routine after freeing the allocated arrays. ! !---------------------------------------------------------------------------------! - deallocate(kke,mfo,mb,cldidx) + deallocate(kke ) + deallocate(diagkke) + deallocate(mfo ) + deallocate(mb ) + deallocate(cldidx ) exit queq_loop elseif (any(mb < 0.) .or. any(diagkke == 0.)) then !---------------------------------------------------------------------------------! @@ -1184,7 +1233,12 @@ subroutine grell_arakschu_solver(nclouds,cldd,clds,mgmzp,dtime,p_cup,clim,whlev, end if end do !----- Free memory so it will be ready to be allocated next time. ----------------! - deallocate(kke,diagkke,mfo,mb,cldidx) + deallocate(kke ) + deallocate(diagkke) + deallocate(mfo ) + deallocate(mb ) + deallocate(cldidx ) + !---------------------------------------------------------------------------------! else !---------------------------------------------------------------------------------! ! All mass flux terms are zero or positive, we are all set. Simply copy the ! @@ -1197,7 +1251,12 @@ subroutine grell_arakschu_solver(nclouds,cldd,clds,mgmzp,dtime,p_cup,clim,whlev, upmx(jcld) = max(0.,mfo(jsol) / kke(jsol,jsol)) end do !----- Free memory before leaving the subroutine. --------------------------------! - deallocate(kke,diagkke,mfo,mb,cldidx) + deallocate(kke ) + deallocate(diagkke) + deallocate(mfo ) + deallocate(mb ) + deallocate(cldidx ) + !---------------------------------------------------------------------------------! exit queq_loop end if @@ -1295,8 +1354,13 @@ subroutine grell_inre_solver(nclouds,cldd,clds,tscal,fac,aatot0,mfke,ierr,upmf,u if (nsolv == 0) exit inre_loop !----- Allocate some vectors we need for solving the linear system. -----------------! - allocate(kke(nsolv,nsolv),diagkke(nsolv),mfo(nsolv),mb(nsolv),cldidx(nsolv)) - + allocate(kke (nsolv,nsolv)) + allocate(diagkke (nsolv)) + allocate(mfo (nsolv)) + allocate(mb (nsolv)) + allocate(cldidx (nsolv)) + !------------------------------------------------------------------------------------! + !----- Store the actual cloud number of those clouds cldidx = pack(cloud,okcld) @@ -1340,7 +1404,11 @@ subroutine grell_inre_solver(nclouds,cldd,clds,tscal,fac,aatot0,mfke,ierr,upmf,u ! The matrix is singular or almost singular, so we cannot solve these clouds. ! ! We can quit this routine after freeing the allocated arrays. ! !---------------------------------------------------------------------------------! - deallocate(kke,diagkke,mfo,mb,cldidx) + deallocate(kke ) + deallocate(diagkke) + deallocate(mfo ) + deallocate(mb ) + deallocate(cldidx ) exit inre_loop elseif (any(mb < 0.) .or. any(diagkke == 0.)) then !---------------------------------------------------------------------------------! @@ -1354,7 +1422,12 @@ subroutine grell_inre_solver(nclouds,cldd,clds,tscal,fac,aatot0,mfke,ierr,upmf,u end if end do !----- Free memory so it will be ready to be allocated next time. ----------------! - deallocate(kke,diagkke,mfo,mb,cldidx) + deallocate(kke ) + deallocate(diagkke) + deallocate(mfo ) + deallocate(mb ) + deallocate(cldidx ) + !---------------------------------------------------------------------------------! else !---------------------------------------------------------------------------------! ! All mass flux terms are zero or positive, we are all set. Simply copy the ! @@ -1367,7 +1440,12 @@ subroutine grell_inre_solver(nclouds,cldd,clds,tscal,fac,aatot0,mfke,ierr,upmf,u upmx(jcld) = max(0.,mfo(jsol) / kke(jsol,jsol)) end do !----- Free memory before leaving the subroutine. --------------------------------! - deallocate(kke,diagkke,mfo,mb,cldidx) + deallocate(kke ) + deallocate(diagkke) + deallocate(mfo ) + deallocate(mb ) + deallocate(cldidx ) + !---------------------------------------------------------------------------------! exit inre_loop end if diff --git a/BRAMS/src/cuparm/grell_cupar_environment.f90 b/BRAMS/src/cuparm/grell_cupar_environment.f90 index be0be7fb5..8319c1aec 100644 --- a/BRAMS/src/cuparm/grell_cupar_environment.f90 +++ b/BRAMS/src/cuparm/grell_cupar_environment.f90 @@ -19,13 +19,13 @@ subroutine grell_thermo_cldlev(mkx,mgmzp,z_cup,exner,thil,t,qtot,qliq,qice,co2,e ,t_cup,thil_cup,qtot_cup,qvap_cup,qliq_cup,qice_cup,qsat_cup & ,co2_cup,rho_cup,theiv_cup,theivs_cup) - use rconstants, only : p00,cpi,cpor,t3ple - use therm_lib , only : & - thetaeiv & ! Function that computes thetae_iv - ,thetaeivs & ! Function that computes sat. thetae_iv - ,idealdens & ! Function that computes density for ideal gas - ,rslif & ! Function that computes saturation mixing ratio - ,theta_iceliq ! ! Function that computes theta_il + use rconstants, only : t3ple ! ! Triple point temperature + use therm_lib , only : thetaeiv & ! Function that computes thetae_iv + , thetaeivs & ! Function that computes sat. thetae_iv + , idealdens & ! Function that computes density for ideal gas + , rslif & ! Function that computes saturation mixing ratio + , theta_iceliq & ! Function that computes theta_il + , exner2press ! ! Function that computes pressure implicit none !------ Input variables ----------------------------------------------------------------! @@ -92,7 +92,7 @@ subroutine grell_thermo_cldlev(mkx,mgmzp,z_cup,exner,thil,t,qtot,qliq,qice,co2,e !---------------------------------------------------------------------------------------! do k = 1,mkx !------ Pressure, straightforward and it could be interpolated too ------------------! - p_cup(k) = p00*(cpi*exner_cup(k))**cpor + p_cup(k) = exner2press(exner_cup(k)) !------ Finding liquid and ice mixing ratio -----------------------------------------! qsat_cup(k) = rslif(p_cup(k),t_cup(k)) @@ -110,7 +110,7 @@ subroutine grell_thermo_cldlev(mkx,mgmzp,z_cup,exner,thil,t,qtot,qliq,qice,co2,e !------ Finding the air density -----------------------------------------------------! rho_cup(k) = idealdens(p_cup(k),t_cup(k),qvap_cup(k),qtot_cup(k)) !------ Finding the ice-vapour equivalent potential temperature ---------------------! - theiv_cup(k) = thetaeiv(thil_cup(k),p_cup(k),t_cup(k),qvap_cup(k),qtot_cup(k),8) + theiv_cup(k) = thetaeiv(thil_cup(k),p_cup(k),t_cup(k),qvap_cup(k),qtot_cup(k)) !------ Finding the saturation ice-vapour equivalent potential temperature ----------! theivs_cup(k) = thetaeivs(thil_cup(k),t_cup(k),qsat_cup(k),qliq_cup(k),qice_cup(k)) end do diff --git a/BRAMS/src/cuparm/grell_cupar_feedback.f90 b/BRAMS/src/cuparm/grell_cupar_feedback.f90 index 3bd0fef87..43dffd8ea 100644 --- a/BRAMS/src/cuparm/grell_cupar_feedback.f90 +++ b/BRAMS/src/cuparm/grell_cupar_feedback.f90 @@ -48,7 +48,7 @@ subroutine grell_cupar_feedback(mgmzp,maxens_cap,maxens_eff,maxens_lsf,maxens_dy outco2 & ! CO2 mixing ratio tendency [ ppm/s] ,outqtot & ! Total water mixing ratio tendency [ kg/kg/s] ,outthil ! ! Ice-liquid pot. temperature tendency [ K/s] - real , intent(inout) :: & + real , dimension(1) , intent(inout) :: & precip ! ! Precipitation rate [kg/m²/s] !----- Arguments, output variables. ----------------------------------------------------! real , intent(inout) :: dnmf ! Ref. dnward mass flx (m0) @@ -70,13 +70,27 @@ subroutine grell_cupar_feedback(mgmzp,maxens_cap,maxens_eff,maxens_lsf,maxens_dy real :: inv_maxens_ec ! 1 / ( maxens_eff * maxens_cap) real :: inv_maxens_eld ! 1 / ( maxens_eff * maxens_cap & ! * maxens_dyn ) + real :: max_heat_si ! Maximum heating rate in K/s !----- Local constant, controlling debugging information. ------------------------------! logical , parameter :: print_debug = .false. !---------------------------------------------------------------------------------------! - !----- Assigning the inverse of part of the ensemble dimension. ------------------------! + + + !----- Assign the inverse of part of the ensemble dimension. ---------------------------! inv_maxens_ec = 1. / (maxens_eff * maxens_cap ) inv_maxens_eld = 1. / (maxens_eff * maxens_lsf * maxens_dyn) + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! Find the maximum heating rate in K/s. ! + !---------------------------------------------------------------------------------------! + max_heat_si = max_heat / day_sec + !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! ! Initialise all output variables. They may become the actual values in case con- ! @@ -91,6 +105,8 @@ subroutine grell_cupar_feedback(mgmzp,maxens_cap,maxens_eff,maxens_lsf,maxens_dy outthil = 0. outqtot = 0. outco2 = 0. + !---------------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------------! ! Before we average, we just need to make sure we don't have negative reference ! @@ -111,6 +127,9 @@ subroutine grell_cupar_feedback(mgmzp,maxens_cap,maxens_eff,maxens_lsf,maxens_dy where (dnmx_ens < 0.) dnmx_ens = 0. end where + !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! ! Find the averaged mass fluxes for each static control. ! @@ -170,22 +189,19 @@ subroutine grell_cupar_feedback(mgmzp,maxens_cap,maxens_eff,maxens_lsf,maxens_dy !---------------------------------------------------------------------------------------! ! Average the temperature tendency among the precipitation efficiency ensemble. If it ! - ! is heating/cooling too much, rescale the reference upward mass flux. Since max_heat ! - ! is given in K/day, I will compute outt in K/day just to test the value and check ! - ! whether it is outside the allowed range or not. After I'm done, I will rescale it ! - ! back to K/s. ! + ! is heating/cooling too much, rescale the reference upward mass flux. ! !---------------------------------------------------------------------------------------! do k=1,mkx outthil(k) = upmf * sum(dellathil_eff(k,1:maxens_eff,1:maxens_cap)) & - * inv_maxens_ec * day_sec + * inv_maxens_ec end do !----- Get minimum and maximum outt, and where they happen -----------------------------! kmin = minloc(outthil,dim=1) kmax = maxloc(outthil,dim=1) !----- If excessive heat happens, scale down both updrafts and downdrafts --------------! - if (kmax > 2 .and. outthil(kmax) > max_heat) then - rescale = max_heat / outthil(kmax) + if (kmax > 2 .and. outthil(kmax) > max_heat_si) then + rescale = max_heat_si / outthil(kmax) upmf = upmf * rescale dnmf = dnmf * rescale upmx = upmx * rescale @@ -197,8 +213,8 @@ subroutine grell_cupar_feedback(mgmzp,maxens_cap,maxens_eff,maxens_lsf,maxens_dy end do end if !----- If excessive cooling happens, scale down both updrafts and downdrafts. ----------! - if (outthil(kmin) < - max_heat) then - rescale = - max_heat/ outthil(kmin) + if (outthil(kmin) < - max_heat_si) then + rescale = - max_heat_si/ outthil(kmin) upmf = upmf * rescale dnmf = dnmf * rescale upmx = upmx * rescale @@ -211,8 +227,8 @@ subroutine grell_cupar_feedback(mgmzp,maxens_cap,maxens_eff,maxens_lsf,maxens_dy end if !----- Heating close to the surface needs to be smaller, being strict there ------------! do k=1,2 - if (outthil(k) > 0.5 * max_heat) then - rescale = 0.5 * max_heat / outthil(k) + if (outthil(k) > 0.5 * max_heat_si) then + rescale = 0.5 * max_heat_si / outthil(k) upmf = upmf * rescale dnmf = dnmf * rescale upmx = upmx * rescale @@ -224,10 +240,6 @@ subroutine grell_cupar_feedback(mgmzp,maxens_cap,maxens_eff,maxens_lsf,maxens_dy end do end if end do - !----- Converting outthil to K/s -------------------------------------------------------! - do k=1,mkx - outthil(k) = outthil(k) / day_sec - end do !---------------------------------------------------------------------------------------! @@ -240,24 +252,29 @@ subroutine grell_cupar_feedback(mgmzp,maxens_cap,maxens_eff,maxens_lsf,maxens_dy outco2(k) = upmf * sum(dellaco2_eff (k,1:maxens_eff,1:maxens_cap)) & * inv_maxens_ec end do + !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! - ! Computing precipitation. It should never be negative, so making sure that this ! - ! never happens. I will skip this in case this cloud is too shallow. ! + ! Compute precipitation. It should never be negative, so we check whether this ever ! + ! happens. ! !---------------------------------------------------------------------------------------! if (any(comp_down_cap)) then do icap=1,maxens_cap do iedt=1,maxens_eff - precip = precip + upmf * max(0.,sum(pw_eff(1:mkx,iedt,icap))) + do k=1,mkx + precip(1) = precip(1) + upmf * pw_eff(k,iedt,icap) + end do end do end do - precip = precip * inv_maxens_ec + precip(1) = max(0.,precip(1)) * inv_maxens_ec end if !---------------------------------------------------------------------------------------! ! Redefining epsilon. ! !---------------------------------------------------------------------------------------! - if (any(comp_down_cap) .and. upmf > 0) then + if (any(comp_down_cap) .and. upmf > 0.) then edt = dnmf/upmf end if @@ -266,7 +283,7 @@ subroutine grell_cupar_feedback(mgmzp,maxens_cap,maxens_eff,maxens_lsf,maxens_dy iun=mynum+50 write(unit=iun,fmt='(a)') '---------------------------------------------------------' write(unit=iun,fmt='(3(a,1x,i5,1x))') ' I=',i,'J=',j,'ICLD=',icld - write(unit=iun,fmt='(4(a,1x,f10.4,1x))') ' PRECIP =',precip & + write(unit=iun,fmt='(4(a,1x,f10.4,1x))') ' PRECIP =',precip(1) & ,' EDT =',edt & ,' DNMF =',dnmf & ,' UPMF =',upmf @@ -475,14 +492,11 @@ subroutine grell_cupar_output(m1,mgmzp,maxens_cap,rtgt,zm,zt,dnmf,upmf,dnmx,upmx ,outthil,precip,xierr,zklod,zklou,zklcl,zklfc,zkdt,zklnb & ,zktop,conprr,thsrc,rtsrc,co2src,areadn,areaup,wdndraft & ,wupdraft,wbuoymin,cuprliq,cuprice,i,j,icld,mynum) - use mem_ensemble , only : & - ensemble_vars ! ! type - use mem_scratch_grell, only : & - kgoff & ! intent(in) - BRAMS grid offset - ,mkx ! ! intent(in) - # of cloud grid levels - - use rconstants , only : & - toodry ! ! intent(in) - Minimum mixing ratio [ kg/kg] + use mem_ensemble , only : ensemble_vars ! ! type + use mem_scratch_grell, only : kgoff & ! intent(in) + , mkx ! ! intent(in) + use rconstants , only : toodry & ! intent(in) + , day_sec ! ! intent(in) implicit none !----- Arguments. ----------------------------------------------------------------------! integer , intent(in) :: m1 ! Number of levels @@ -532,7 +546,7 @@ subroutine grell_cupar_output(m1,mgmzp,maxens_cap,rtgt,zm,zt,dnmf,upmf,dnmx,upmx real , dimension(mgmzp) , intent(in) :: outco2 real , dimension(mgmzp) , intent(in) :: outqtot real , dimension(mgmzp) , intent(in) :: outthil - real , intent(in) :: precip + real , dimension( 1) , intent(in) :: precip !----- Output variables. ---------------------------------------------------------------! real, dimension(m1), intent(inout) :: thsrc ! Potential temperature fdbck [ K/s] real, dimension(m1), intent(inout) :: rtsrc ! Total mixing ratio feedback [kg/kg/s] @@ -561,6 +575,7 @@ subroutine grell_cupar_output(m1,mgmzp,maxens_cap,rtgt,zm,zt,dnmf,upmf,dnmx,upmx integer :: kr ! BRAMS level counter real :: exner ! Exner fctn. for tend. conv. [ J/kg/K] real :: nmoki ! 1/nmok + real :: zhgt ! Height integer :: klod ! Downdraft origin integer :: klou ! Updraft origin integer :: klcl ! Lifting condensation level @@ -573,9 +588,7 @@ subroutine grell_cupar_output(m1,mgmzp,maxens_cap,rtgt,zm,zt,dnmf,upmf,dnmx,upmx real, dimension(m1,maxens_cap) :: cuprice_cap ! Cumulus ice mixing ratio [ kg/kg] !----- Local constants, for debugging. -------------------------------------------------! integer :: iun - logical, parameter :: print_debug=.false. - character(len=9) , parameter :: fmti='(a,1x,i6)' - character(len=13), parameter :: fmtf='(a,1x,es14.7)' + logical , parameter :: print_debug=.false. !---------------------------------------------------------------------------------------! @@ -637,6 +650,8 @@ subroutine grell_cupar_output(m1,mgmzp,maxens_cap,rtgt,zm,zt,dnmf,upmf,dnmx,upmx ktop = max(1,min(mkx,nint(real(sum(ktop_cap ,mask = is_cloud))/nmok))) !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! ! Fix the levels, here I will add back the offset so the output will be consistent. ! ! I shall return these variables even when no cloud developed for debugging purposes. ! @@ -648,12 +663,15 @@ subroutine grell_cupar_output(m1,mgmzp,maxens_cap,rtgt,zm,zt,dnmf,upmf,dnmx,upmx zklod = (zt(klod + kgoff)-zm(kgoff))*rtgt zklnb = (zt(klnb + kgoff)-zm(kgoff))*rtgt zktop = (zt(ktop + kgoff)-zm(kgoff))*rtgt + !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! ! Precipitation is simply copied, it could even be output directly from the main ! ! subroutine, brought here just to be together with the other source terms. ! !---------------------------------------------------------------------------------------! - conprr = precip + conprr = precip(1) do k=1,mkx kr = k + kgoff @@ -662,6 +680,9 @@ subroutine grell_cupar_output(m1,mgmzp,maxens_cap,rtgt,zm,zt,dnmf,upmf,dnmx,upmx rtsrc(kr) = outqtot(k) co2src(kr) = outco2(k) end do + !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! ! Compute the relative area covered by downdrafts and updrafts. ! @@ -685,6 +706,9 @@ subroutine grell_cupar_output(m1,mgmzp,maxens_cap,rtgt,zm,zt,dnmf,upmf,dnmx,upmx end do end if end do stacloop + !---------------------------------------------------------------------------------------! + + !----- Find the averaged area. ---------------------------------------------------------! areadn = sum(areadn_cap) * nmoki @@ -692,10 +716,65 @@ subroutine grell_cupar_output(m1,mgmzp,maxens_cap,rtgt,zm,zt,dnmf,upmf,dnmx,upmx wdndraft = sum(wdndraft_cap) * nmoki wupdraft = sum(wupdraft_cap) * nmoki wbuoymin = sum(wbuoymin_cap) * nmoki - do kr=1,m1 - cuprliq(kr) = sum(cuprliq_cap(kr,1:maxens_cap)) * nmoki - cuprice(kr) = sum(cuprice_cap(kr,1:maxens_cap)) * nmoki + do icap=1,maxens_cap + do kr=1,m1 + cuprliq(kr) = cuprliq(kr) + cuprliq_cap(kr,icap) * nmoki + cuprice(kr) = cuprice(kr) + cuprice_cap(kr,icap) * nmoki + end do end do + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! If printing debug, check whether the cloud happened and print the cloud ! + ! characteristics. ! + !---------------------------------------------------------------------------------------! + if (print_debug) then + write(unit=20+icld,fmt='(92a)' ) ('-',k=1,92) + write(unit=20+icld,fmt='(a)' ) '' + write(unit=20+icld,fmt='(a,1x,i5)' ) ' I =',i + write(unit=20+icld,fmt='(a,1x,i5)' ) ' J =',j + write(unit=20+icld,fmt='(a,1x,i5)' ) ' NMOK =',nint(nmok) + write(unit=20+icld,fmt='(a)' ) '' + write(unit=20+icld,fmt='(a,1x,i5,1x,f10.2)') ' DET =',kdet,zkdt + write(unit=20+icld,fmt='(a,1x,i5,1x,f10.2)') ' LOU =',klou,zklou + write(unit=20+icld,fmt='(a,1x,i5,1x,f10.2)') ' LCL =',klcl,zklcl + write(unit=20+icld,fmt='(a,1x,i5,1x,f10.2)') ' LFC =',klfc,zklfc + write(unit=20+icld,fmt='(a,1x,i5,1x,f10.2)') ' LOD =',klod,zklod + write(unit=20+icld,fmt='(a,1x,i5,1x,f10.2)') ' LNB =',klnb,zklnb + write(unit=20+icld,fmt='(a,1x,i5,1x,f10.2)') ' TOP =',ktop,zktop + write(unit=20+icld,fmt='(a)' ) '' + write(unit=20+icld,fmt='(a,1x,es12.5)' ) ' DNMF =',dnmf + write(unit=20+icld,fmt='(a,1x,es12.5)' ) ' UPMF =',upmf + write(unit=20+icld,fmt='(a,1x,es12.5)' ) ' DNMX =',dnmx + write(unit=20+icld,fmt='(a,1x,es12.5)' ) ' UPMX =',upmx + write(unit=20+icld,fmt='(a,1x,es12.5)' ) ' AREADN =',areadn + write(unit=20+icld,fmt='(a,1x,es12.5)' ) ' AREAUP =',areaup + write(unit=20+icld,fmt='(a,1x,es12.5)' ) ' WDNDRAFT =',wdndraft + write(unit=20+icld,fmt='(a,1x,es12.5)' ) ' WUPDRAFT =',wupdraft + write(unit=20+icld,fmt='(a,1x,es12.5)' ) ' WBUOYMIN =',wbuoymin + write(unit=20+icld,fmt='(a,1x,es12.5)' ) ' CONPRR =',conprr * day_sec + write(unit=20+icld,fmt='(a)' ) '' + write(unit=20+icld,fmt='(7(a,1x))') ' K',' HEIGHT',' THSRC' & + ,' RTSRC',' CO2SRC',' CUPRICE' & + ,' CUPRLIQ' + write(unit=20+icld,fmt='(92(a))') ('-',k=1,92) + do k=m1,1,-1 + zhgt = ( zt(k+kgoff) - zm(kgoff) ) * rtgt + write (unit=20+icld,fmt='(i12,1x,f12.2,1x,5(es12.5,1x))') & + k & + , zhgt & + , thsrc (k) * day_sec & + , rtsrc (k) * day_sec * 1000. & + , co2src (k) * day_sec & + , cuprice(k) * 1000. & + , cuprliq(k) * 1000. + end do + write(unit=20+icld,fmt='(92(a))') ('-',k=1,92) + write(unit=20+icld,fmt='(a)' ) '' + end if + !---------------------------------------------------------------------------------------! return diff --git a/BRAMS/src/cuparm/grell_cupar_static.f90 b/BRAMS/src/cuparm/grell_cupar_static.f90 index f31fc9290..80693b312 100644 --- a/BRAMS/src/cuparm/grell_cupar_static.f90 +++ b/BRAMS/src/cuparm/grell_cupar_static.f90 @@ -31,6 +31,8 @@ subroutine grell_cupar_static(comp_noforc_cldwork,checkmass,iupmethod,maxens_cap ,etad_cld_cap,etau_cld_cap,rhod_cld_cap,rhou_cld_cap & ,qliqd_cld_cap,qliqu_cld_cap,qiced_cld_cap,qiceu_cld_cap,i,j & ,icld,mynum) + use grid_dims , only : & + str_len ! ! intent(in) - Typical string length. use mem_ensemble , only : & ensemble_vars ! ! structure - The ensemble scratch structure. ----------! @@ -180,6 +182,7 @@ subroutine grell_cupar_static(comp_noforc_cldwork,checkmass,iupmethod,maxens_cap ,wbuoymin0 & ! intent(out) - Updraft Minimum buoyant velocity [ m/s] ,wbuoymin ! ! intent(out) - Minimum buoyancy velocity [ ---] use rconstants, only : toodry + use therm_lib , only : toler implicit none !---------------------------------------------------------------------------------------! @@ -301,6 +304,8 @@ subroutine grell_cupar_static(comp_noforc_cldwork,checkmass,iupmethod,maxens_cap real :: edt ! dnmf/upmf [ ---] !----- Scratch array -------------------------------------------------------------------! real, dimension(mgmzp) :: scrvar ! Scratch variable + !----- String for sanity check. --------------------------------------------------------! + character(len=str_len) :: which !----- Parameter to print debug stuff. -------------------------------------------------! logical, parameter :: print_debug=.false. !---------------------------------------------------------------------------------------! @@ -405,12 +410,17 @@ subroutine grell_cupar_static(comp_noforc_cldwork,checkmass,iupmethod,maxens_cap !------------------------------------------------------------------------------------! ! G. Calculate all thermodynamic properties at the cloud level. The cloud levels are ! - ! staggered in relation to BRAMS model. ! + ! staggered in relation to BRAMS model. We must check whether the result is ! + ! reasonable. ! !------------------------------------------------------------------------------------! call grell_thermo_cldlev(mkx,mgmzp,z_cup,exner,thil,t,qtot,qliq,qice,co2,exnersur & ,thilsur,tsur,qtotsur,qliqsur,qicesur,co2sur,exner_cup,p_cup & ,t_cup,thil_cup,qtot_cup,qvap_cup,qliq_cup,qice_cup,qsat_cup & ,co2_cup,rho_cup,theiv_cup,theivs_cup) + write(which,fmt='(2(a,i4.4))') 'extrap_environment_icap=',icap,'_icld=',icld + call grell_sanity_check(mkx,mgmzp,z_cup,p_cup,exner_cup,theiv_cup,thil_cup,t_cup & + ,qtot_cup,qvap_cup,qliq_cup,qice_cup,co2_cup,rho_cup & + ,which) !------------------------------------------------------------------------------------! ! H. Initialise drafts liquid mixing ratio and density. These will be the ! @@ -452,7 +462,7 @@ subroutine grell_cupar_static(comp_noforc_cldwork,checkmass,iupmethod,maxens_cap end if !------------------------------------------------------------------------------------! - ! 3. Finding the level of free convection. Two important points here: ! + ! 3. Find the level of free convection. Two important points here: ! ! a. This call may end up preventing convection, so I must check after the call ! ! b. This subroutine may also affect the updraft originating level. ! !------------------------------------------------------------------------------------! @@ -469,13 +479,13 @@ subroutine grell_cupar_static(comp_noforc_cldwork,checkmass,iupmethod,maxens_cap end if !------------------------------------------------------------------------------------! - ! 4. Finding the minimum saturation thetae_iv. This will be the bottom of the stable ! + ! 4. Find the minimum saturation thetae_iv. This will be the bottom of the stable ! ! layer. ! !------------------------------------------------------------------------------------! kstabi=(klfc - 1) + minloc(theivs_cup(klfc:kstabm),dim=1) !------------------------------------------------------------------------------------! - ! 5. Increasing the detrainment in stable layers provided that there is such layer. ! + ! 5. Increase the detrainment in stable layers provided that there is such layer. ! ! this rate increases linearly until a maximum value, currently set to 10 times ! ! the entrainment rate. If the cloud is sufficiently small, we further simplify ! ! and assume detrainment to be equal to entrainment (otherwise the detrainment ! @@ -494,14 +504,15 @@ subroutine grell_cupar_static(comp_noforc_cldwork,checkmass,iupmethod,maxens_cap ,theivu_cld) !------------------------------------------------------------------------------------! - ! 7. Finding the normalized mass fluxes associated with updrafts. Since we are using ! + ! 7. Find the normalized mass fluxes associated with updrafts. Since we are using ! ! height-based vertical coordinate, there is no need to find the forced ! ! normalized mass flux, they'll be the same, so just copy it afterwards. ! !------------------------------------------------------------------------------------! call grell_nms_updraft(mkx,mgmzp,klou,klfc,ktpse,mentru_rate,cdu,dzu_cld,etau_cld) !------------------------------------------------------------------------------------! - ! 8. Finding the moisture profiles associated with updrafts. ! + ! 8. Find the moisture profiles associated with updrafts, and check whether the ! + ! profile makes sense or not. ! !------------------------------------------------------------------------------------! call grell_most_thermo_updraft(prec_cld,.true.,mkx,mgmzp,klfc,ktpse & ,cld2prec,cdu,mentru_rate,qtot,co2,p_cup,exner_cup & @@ -510,9 +521,13 @@ subroutine grell_cupar_static(comp_noforc_cldwork,checkmass,iupmethod,maxens_cap ,dzu_cld,thilu_cld,tu_cld,qtotu_cld,qvapu_cld & ,qliqu_cld,qiceu_cld,qsatu_cld,co2u_cld,rhou_cld,dbyu & ,pwu_cld,pwav,klnb,ktop,ierr) + write(which,fmt='(2(a,i4.4))') 'extrap_updraft_icap=',icap,'_icld=',icld + call grell_sanity_check(mkx,mgmzp,z_cup,p_cup,exner_cup,theivu_cld,thilu_cld,tu_cld & + ,qtotu_cld,qvapu_cld,qliqu_cld,qiceu_cld,co2u_cld,rhou_cld & + ,which) !------------------------------------------------------------------------------------! - ! 9. Checking whether we found a cloud top. Since this may keep convection to ! + ! 9. Check whether we found a cloud top. Since this may keep convection to ! ! happen, I check whether I should move on or break here. Also check whether ! ! this cloud qualifies to be in this spectrum size. It need to be thicker than ! ! the minimum value provided by the user, and there must be some condensation ! @@ -530,7 +545,7 @@ subroutine grell_cupar_static(comp_noforc_cldwork,checkmass,iupmethod,maxens_cap end if !------------------------------------------------------------------------------------! - !10. Finding the cloud work function associated with updrafts. If this cloud doesn't ! + !10. Find the cloud work function associated with updrafts. If this cloud doesn't ! ! produce cloud work, break the run, we don't simulate lazy clouds in this model. ! !------------------------------------------------------------------------------------! call grell_cldwork_updraft(mkx,mgmzp,klou,ktop,dbyu,dzu_cld,etau_cld,aau) @@ -545,7 +560,7 @@ subroutine grell_cupar_static(comp_noforc_cldwork,checkmass,iupmethod,maxens_cap ![[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[! !------------------------------------------------------------------------------------! - ! J. Finding the downdraft counterpart of the above properties, namely where the ! + ! J. Find the downdraft counterpart of the above properties, namely where the ! ! downdrafts detrain all its mass, where they originate, their mass, energy and ! ! moisture properties. This should be done only when it is a cloud that has ! ! downdrafts. In case we cannot find a suitable level in which downdrafts ! @@ -596,7 +611,8 @@ subroutine grell_cupar_static(comp_noforc_cldwork,checkmass,iupmethod,maxens_cap ,theivs_cup,dzd_cld,theivd_cld) !---------------------------------------------------------------------------------! - ! 6. Moisture properties of downdraft. If buoyancy happens to be non-sense, we ! + ! 6. Moisture properties of downdraft, and its sanity check. Besides the thermo- ! + ! dynamics, we must check whether buoyancy makes sense, in case it doesn't we ! ! will assign an error flag to this cloud and don't let it happen. ! !---------------------------------------------------------------------------------! call grell_most_thermo_downdraft(mkx,mgmzp,klod,qtot,co2,mentrd_rate,cdd,p_cup & @@ -606,6 +622,10 @@ subroutine grell_cupar_static(comp_noforc_cldwork,checkmass,iupmethod,maxens_cap ,qtotd_cld,qvapd_cld,qliqd_cld,qiced_cld & ,qsatd_cld,co2d_cld,rhod_cld,dbyd,pwd_cld,pwev & ,ierr) + write(which,fmt='(2(a,i4.4))') 'extrap_downdraft_icap=',icap,'_icld=',icld + call grell_sanity_check(mkx,mgmzp,z_cup,p_cup,exner_cup,theivd_cld,thild_cld & + ,td_cld,qtotd_cld,qvapd_cld,qliqd_cld,qiced_cld,co2d_cld & + ,rhod_cld,which) if (ierr /= 0) then ierr_cap(icap) = ierr cycle stacloop @@ -618,9 +638,12 @@ subroutine grell_cupar_static(comp_noforc_cldwork,checkmass,iupmethod,maxens_cap call grell_efficiency_ensemble(mkx,mgmzp,maxens_eff,klou,klfc,klnb,edtmin,edtmax & ,pwav,pwev,z_cup,uwind,vwind,dzd_cld & ,edt_eff(:,icap)) + !------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------! - ! 8. Checking for water availability and evaporation consistency: we assume that ! + ! 8. Check for water availability and evaporation consistency: we assume that ! ! downdraft is always saturated, and it gets the moisture from the rain. How- ! ! ever, it cannot require more rain than what is available, so if that would ! ! be the case, we don't allow this cloud to exist. ! @@ -631,11 +654,16 @@ subroutine grell_cupar_static(comp_noforc_cldwork,checkmass,iupmethod,maxens_cap cycle stacloop end if end do ddcheckloop + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! - ! 9. Computing cloud work function associated with downdrafts. ! + ! 9. Compute cloud work function associated with downdrafts. ! !---------------------------------------------------------------------------------! call grell_cldwork_downdraft(mkx,mgmzp,klod,dbyd,dzd_cld,etad_cld,aad) + !---------------------------------------------------------------------------------! else !---------------------------------------------------------------------------------! @@ -663,14 +691,14 @@ subroutine grell_cupar_static(comp_noforc_cldwork,checkmass,iupmethod,maxens_cap ![[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[! !------------------------------------------------------------------------------------! - ! K. Finding the non-forced cloud work, which will require computing most ! - ! subroutines again. This will go and compute even if the tests would prevent ! - ! the cloud to happen. This part will be skipped if the user is asking for moist- ! - ! ure convergence only. ! + ! K. Find the non-forced cloud work, which will require computing most subroutines ! + ! again. This will go and compute even if the tests would prevent the cloud to ! + ! happen. This part will be skipped if the user is asking for moisture ! + ! convergence only. ! !------------------------------------------------------------------------------------! if (comp_noforc_cldwork) then !---------------------------------------------------------------------------------! - ! i. Initialising error flag ! + ! i. Initialise error flag. ! !---------------------------------------------------------------------------------! ierr0 = 0 comp_dn0 = comp_dn @@ -683,13 +711,17 @@ subroutine grell_cupar_static(comp_noforc_cldwork,checkmass,iupmethod,maxens_cap !---------------------------------------------------------------------------------! ! iii. Calculate all thermodynamic properties at the cloud level and initialize ! - ! draft thermodynamic properties ! + ! draft thermodynamic properties (sanity check too...). ! !---------------------------------------------------------------------------------! call grell_thermo_cldlev(mkx,mgmzp,z_cup,exner0,thil0,t0,qtot0,qliq0,qice0,co20 & ,exnersur,thilsur,tsur,qtotsur,qliqsur,qicesur,co2sur & ,exner0_cup,p0_cup,t0_cup,thil0_cup,qtot0_cup,qvap0_cup & ,qliq0_cup,qice0_cup,qsat0_cup,co20_cup,rho0_cup & ,theiv0_cup,theivs0_cup) + write(which,fmt='(2(a,i4.4))') 'zero_environment_icap=',icap,'_icld=',icld + call grell_sanity_check(mkx,mgmzp,z_cup,p0_cup,exner0_cup,theiv0_cup,thil0_cup & + ,t0_cup,qtot0_cup,qvap0_cup,qliq0_cup,qice0_cup,co20_cup & + ,rho0_cup,which) !---------------------------------------------------------------------------------! ! iv. Calculate the thermodynamic properties below the level of free convec- ! @@ -708,7 +740,8 @@ subroutine grell_cupar_static(comp_noforc_cldwork,checkmass,iupmethod,maxens_cap ,dzu_cld,theiv0u_cld) !---------------------------------------------------------------------------------! - ! vi. Finding the moisture profiles associated with updrafts. ! + ! vi. Find the moisture profiles associated with updrafts, and check whether ! + ! they make sense or not. ! !---------------------------------------------------------------------------------! call grell_most_thermo_updraft(comp_down_cap(icap),.false.,mkx,mgmzp,klfc,ktop & ,cld2prec,cdu,mentru_rate,qtot0,co20,p0_cup & @@ -718,8 +751,13 @@ subroutine grell_cupar_static(comp_noforc_cldwork,checkmass,iupmethod,maxens_cap ,t0u_cld,qtot0u_cld,qvap0u_cld,qliq0u_cld & ,qice0u_cld,qsat0u_cld,co20u_cld,rho0u_cld,dby0u & ,pw0u_cld,pwav0,klnb0,ktop0,ierr0) + write(which,fmt='(2(a,i4.4))') 'zero_updraft_icap=',icap + call grell_sanity_check(mkx,mgmzp,z_cup,p0_cup,exner0_cup,theiv0u_cld,thil0u_cld & + ,t0u_cld,qtot0u_cld,qvap0u_cld,qliq0u_cld,qice0u_cld & + ,co20u_cld,rho0u_cld,which) + !---------------------------------------------------------------------------------! - ! vii. Finding the cloud work function ! + ! vii. Find the cloud work function. ! !---------------------------------------------------------------------------------! call grell_cldwork_updraft(mkx,mgmzp,klou,ktop,dby0u,dzu_cld,etau_cld,aa0u) @@ -742,6 +780,10 @@ subroutine grell_cupar_static(comp_noforc_cldwork,checkmass,iupmethod,maxens_cap ,qvap0d_cld,qliq0d_cld,qice0d_cld,qsat0d_cld & ,co20d_cld,rho0d_cld,dby0d,pw0d_cld,pwev0 & ,ierr0) + write(which,fmt='(a,i4.4)') 'zero_downdraft_icap=',icap + call grell_sanity_check(mkx,mgmzp,z_cup,p0_cup,exner0_cup,theiv0d_cld & + ,thil0d_cld,t0d_cld,qtot0d_cld,qvap0d_cld,qliq0d_cld & + ,qice0d_cld,co20d_cld,rho0d_cld,which) !------------------------------------------------------------------------------! ! x. Downdraft cloud work function. ! diff --git a/BRAMS/src/cuparm/grell_cupar_updraft.f90 b/BRAMS/src/cuparm/grell_cupar_updraft.f90 index 8eb9ede48..bfc3b7156 100644 --- a/BRAMS/src/cuparm/grell_cupar_updraft.f90 +++ b/BRAMS/src/cuparm/grell_cupar_updraft.f90 @@ -119,7 +119,8 @@ recursive subroutine grell_find_cloud_lfc(mkx,mgmzp,kbmax,cap_max,wnorm_max,wwin use rconstants, only : epi & ! intent(in) , rdry ! ! intent(in) use therm_lib , only : idealdens & ! function - , lcl_il ! ! subroutine + , lcl_il & ! subroutine + , thil2tqall ! ! subroutine use mem_cuparm, only : wcldbs ! ! intent(in) implicit none @@ -207,7 +208,7 @@ recursive subroutine grell_find_cloud_lfc(mkx,mgmzp,kbmax,cap_max,wnorm_max,wwin ! really lucky...). ! !---------------------------------------------------------------------------------------! call lcl_il(thil_cup(klou),p_cup(klou),t_cup(klou),qtot_cup(klou),qvap_cup(klou) & - ,tlcl,plcl,dzlcl,19) + ,tlcl,plcl,dzlcl) klcl = klou klclloop: do if (klcl == mkx .or. plcl >= p_cup(klcl)) exit klclloop @@ -323,8 +324,10 @@ subroutine grell_buoy_below_lfc(mkx,mgmzp,klou,klfc,exner_cup,p_cup,theiv_cup,th ,t_cup,qtot_cup,qvap_cup,qliq_cup,qice_cup,qsat_cup,co2_cup & ,rho_cup,theivu_cld,thilu_cld,tu_cld,qtotu_cld,qvapu_cld & ,qliqu_cld,qiceu_cld,qsatu_cld,co2u_cld,rhou_cld,dbyu) - use rconstants, only : epi,rdry - use therm_lib , only : idealdens + use rconstants, only : epi & ! intent(in) + , rdry ! ! intent(in) + use therm_lib , only : idealdens & ! function + , thil2tqall ! ! subroutine implicit none integer , intent(in) :: mkx ! # of vertical layers @@ -519,7 +522,7 @@ subroutine grell_most_thermo_updraft(preccld,check_top,mkx,mgmzp,klfc,ktpse,cld2 ,qiceu_cld,qsatu_cld,co2u_cld,rhou_cld,dbyu,pwu_cld & ,pwavu,klnb,ktop,ierr) use rconstants, only : epi,rdry, t00, toodry, toowet - use therm_lib , only : thetaeiv2thil, idealdens, toler, maxfpo + use therm_lib , only : thetaeiv2thil, thil2tqall, idealdens, toler, maxfpo implicit none !----- Several scalars. ----------------------------------------------------------------! logical , intent(in) :: preccld ! Flag for precipitation diff --git a/BRAMS/src/cuparm/grell_extras_catt.f90 b/BRAMS/src/cuparm/grell_extras_catt.f90 index f9042f2c9..79f3e20a8 100644 --- a/BRAMS/src/cuparm/grell_extras_catt.f90 +++ b/BRAMS/src/cuparm/grell_extras_catt.f90 @@ -374,7 +374,9 @@ subroutine get_sc_up_wet( mgmzp,n1,se,se_cup,sc_up,k22,kbcon,ktop,cd, & iwd =1 iall=0 - call azero3(mgmzp,sc_up_c,pw_up,henry_coef) + call azero(mgmzp,sc_up_c) + call azero(mgmzp,pw_up) + call azero(mgmzp,henry_coef) do k=1,k22-1 diff --git a/BRAMS/src/cuparm/kuo_cupar_driver.f90 b/BRAMS/src/cuparm/kuo_cupar_driver.f90 index db3503d99..fca444a44 100644 --- a/BRAMS/src/cuparm/kuo_cupar_driver.f90 +++ b/BRAMS/src/cuparm/kuo_cupar_driver.f90 @@ -208,9 +208,9 @@ subroutine conpar(m1,m2,m3,ia,iz,ja,jz,ibcon,up,vp,wp,theta,pp,pi0,dn0,rv,thsrc, wcon(k) = wp(k,i,j) thtcon(k) = theta(k,i,j) picon(k) = (pp(k,i,j)+pi0(k,i,j)) - tmpcon(k) = thtcon(k)*picon(k)/cp + tmpcon(k) = thtcon(k)*picon(k)/cpdry dncon(k) = dn0(k,i,j) - prcon(k) = (picon(k)/cp)**cpor*p00 + prcon(k) = (picon(k)/cpdry)**cpor*p00 rvcon(k) = rv(k,i,j) zcon(k) = zt(k) *rtgt(i,j) zzcon(k) = zm(k) *rtgt(i,j) @@ -287,7 +287,7 @@ subroutine cu_environ(k1,k2) !----- Compute moist static energy profile ---------------------------------------------! do k=k1,k2 - hz(k)=cp*tmpcon(k)+grav*zcon(k)+alvl*rvcon(k) + hz(k)=cpdry*tmpcon(k)+grav*zcon(k)+alvl3*rvcon(k) enddo !---------------------------------------------------------------------------------------! @@ -364,12 +364,12 @@ subroutine cu_environ(k1,k2) end do do k=1,kmt - te(k)=the(k)*pke(k)/cp - pe(k)=(pke(k)/cp)**cpor*p00 + te(k)=the(k)*pke(k)/cpdry + pe(k)=(pke(k)/cpdry)**cpor*p00 rhoe(k)=pe(k)/(rdry*virtt(te(k),rve(k))) end do do k=1,kmt - thee(k)=thetaeiv(the(k),pe(k),te(k),rve(k),rve(k),3,.false.) + thee(k)=thetaeiv(the(k),pe(k),te(k),rve(k),rve(k),.false.) end do @@ -401,7 +401,7 @@ subroutine cu_environ(k1,k2) rlll = (rve(kcon)+rve(kcon+1)+rve(kcon-1))/3. zlll = ze(kcon) thlll = tlll * (p00/plll)**rocp - call lcl_il(thlll,plll,tlll,rlll,rlll,tlcl,plcl,dzlcl,1,.false.) + call lcl_il(thlll,plll,tlll,rlll,rlll,tlcl,plcl,dzlcl,.false.) if (dzlcl == 0.) then tlcl = tlll plcl = plll @@ -429,7 +429,7 @@ subroutine cu_environ(k1,k2) ! Locate equilibrium temperature level of an unentrained parcel. compute initial ! ! ABE. If ABE is less than 0, no convection. ! !---------------------------------------------------------------------------------------! - theu(klcl) = the(kcon)*exp(alvl*rve(kcon)/(cp*max(tlcl,ttripoli))) + theu(klcl) = the(kcon)*exp(alvl3*rve(kcon)/(cpdry*max(tlcl,ttripoli))) bypass = .false. eqloop: do k=klcl,kmt @@ -511,7 +511,7 @@ subroutine kuocp() ! This is the cloud model. Updraft is constant THETA e and saturated with respect ! ! to water. There is no ice. Cloud top is one level above ETL. THETA e of the updraft ! !---------------------------------------------------------------------------------------! - theu(klcl)=the(kcon)*exp(alvl*rve(kcon)/(cp*tlcl)) + theu(klcl)=the(kcon)*exp(alvl3*rve(kcon)/(cpdry*tlcl)) !----- Equilibrium Temperature Level of the source level air. --------------------------! igo = 0 @@ -738,7 +738,7 @@ subroutine kuocp() rateloop: do do k=2,kmt - ftcon(k) = alvl*preff*supply*vheat(k) /(pke(k)*rhoe(k)*vhint) + ftcon(k) = alvl3*preff*supply*vheat(k) /(pke(k)*rhoe(k)*vhint) end do do k=klcl,kct frcon(k)=bkuo*supply*vmois(k)/(rhoe(k)*vmint) @@ -820,7 +820,7 @@ subroutine cp2mod(k1,k2) !----- Compute integrated heating and moistening tendencies. ---------------------------! do k=2,kmt qvct1(k) = rhoe(k)*ftcon(k)*pke(k) - qvct2(k) = rhoe(k)*alvl*frcon(k) + qvct2(k) = rhoe(k)*alvl3*frcon(k) qvct3(k) = (zc(k)-zc(k-1))*qvct1(k) qvct4(k) = (zc(k)-zc(k-1))*qvct2(k) end do @@ -853,7 +853,7 @@ subroutine cp2mod(k1,k2) !----- Change energy tendencies to temperature and mixing ratio tendencies. ------------! do k=k1,k2 ftcon(k) = vctr5(k)/((zzcon(k)-zzcon(k-1))*dncon(k)*picon(k)) - frcon(k) = vctr6(k)/((zzcon(k)-zzcon(k-1))*dncon(k)*alvl) + frcon(k) = vctr6(k)/((zzcon(k)-zzcon(k-1))*dncon(k)*alvl3) end do return diff --git a/BRAMS/src/cuparm/mem_cuparm.f90 b/BRAMS/src/cuparm/mem_cuparm.f90 index fbd6c9443..50f3bf1df 100644 --- a/BRAMS/src/cuparm/mem_cuparm.f90 +++ b/BRAMS/src/cuparm/mem_cuparm.f90 @@ -273,41 +273,41 @@ subroutine nullify_cuparm(cuparm) implicit none type (cuparm_vars) :: cuparm - if(associated(cuparm%thsrc )) nullify (cuparm%thsrc ) - if(associated(cuparm%rtsrc )) nullify (cuparm%rtsrc ) - if(associated(cuparm%co2src )) nullify (cuparm%co2src ) - if(associated(cuparm%areadn )) nullify (cuparm%areadn ) - if(associated(cuparm%areaup )) nullify (cuparm%areaup ) - if(associated(cuparm%cuprliq )) nullify (cuparm%cuprliq ) - if(associated(cuparm%cuprice )) nullify (cuparm%cuprice ) - if(associated(cuparm%aconpr )) nullify (cuparm%aconpr ) - if(associated(cuparm%conprr )) nullify (cuparm%conprr ) - if(associated(cuparm%thsrcp )) nullify (cuparm%thsrcp ) - if(associated(cuparm%rtsrcp )) nullify (cuparm%rtsrcp ) - if(associated(cuparm%thsrcf )) nullify (cuparm%thsrcf ) - if(associated(cuparm%rtsrcf )) nullify (cuparm%rtsrcf ) - if(associated(cuparm%conprrp )) nullify (cuparm%conprrp ) - if(associated(cuparm%conprrf )) nullify (cuparm%conprrf ) - if(associated(cuparm%aadn )) nullify (cuparm%aadn ) - if(associated(cuparm%aaup )) nullify (cuparm%aaup ) - if(associated(cuparm%dnmf )) nullify (cuparm%dnmf ) - if(associated(cuparm%dnmx )) nullify (cuparm%dnmx ) - if(associated(cuparm%edt )) nullify (cuparm%edt ) - if(associated(cuparm%upmf )) nullify (cuparm%upmf ) - if(associated(cuparm%upmx )) nullify (cuparm%upmx ) - if(associated(cuparm%wdndraft )) nullify (cuparm%wdndraft ) - if(associated(cuparm%wupdraft )) nullify (cuparm%wupdraft ) - if(associated(cuparm%wbuoymin )) nullify (cuparm%wbuoymin ) - if(associated(cuparm%xierr )) nullify (cuparm%xierr ) - if(associated(cuparm%zklod )) nullify (cuparm%zklod ) - if(associated(cuparm%zklou )) nullify (cuparm%zklou ) - if(associated(cuparm%zkdet )) nullify (cuparm%zkdet ) - if(associated(cuparm%zklcl )) nullify (cuparm%zklcl ) - if(associated(cuparm%zklfc )) nullify (cuparm%zklfc ) - if(associated(cuparm%zklnb )) nullify (cuparm%zklnb ) - if(associated(cuparm%zktop )) nullify (cuparm%zktop ) - if(associated(cuparm%xiact_c )) nullify (cuparm%xiact_c ) - if(associated(cuparm%xiact_p )) nullify (cuparm%xiact_p ) + nullify (cuparm%thsrc ) + nullify (cuparm%rtsrc ) + nullify (cuparm%co2src ) + nullify (cuparm%areadn ) + nullify (cuparm%areaup ) + nullify (cuparm%cuprliq ) + nullify (cuparm%cuprice ) + nullify (cuparm%aconpr ) + nullify (cuparm%conprr ) + nullify (cuparm%thsrcp ) + nullify (cuparm%rtsrcp ) + nullify (cuparm%thsrcf ) + nullify (cuparm%rtsrcf ) + nullify (cuparm%conprrp ) + nullify (cuparm%conprrf ) + nullify (cuparm%aadn ) + nullify (cuparm%aaup ) + nullify (cuparm%dnmf ) + nullify (cuparm%dnmx ) + nullify (cuparm%edt ) + nullify (cuparm%upmf ) + nullify (cuparm%upmx ) + nullify (cuparm%wdndraft ) + nullify (cuparm%wupdraft ) + nullify (cuparm%wbuoymin ) + nullify (cuparm%xierr ) + nullify (cuparm%zklod ) + nullify (cuparm%zklou ) + nullify (cuparm%zkdet ) + nullify (cuparm%zklcl ) + nullify (cuparm%zklfc ) + nullify (cuparm%zklnb ) + nullify (cuparm%zktop ) + nullify (cuparm%xiact_c ) + nullify (cuparm%xiact_p ) return end subroutine nullify_cuparm diff --git a/BRAMS/src/cuparm/mem_ensemble.f90 b/BRAMS/src/cuparm/mem_ensemble.f90 index 3a4952a42..44198ba2b 100644 --- a/BRAMS/src/cuparm/mem_ensemble.f90 +++ b/BRAMS/src/cuparm/mem_ensemble.f90 @@ -141,8 +141,8 @@ module mem_ensemble !------------------------------------------------------------------------------------! ! Scalars, for dynamic control ensemble calculation and feedback. ! !------------------------------------------------------------------------------------! - real :: prev_dnmf ! Dndraft mass flux last time [kg/m²/s] - real :: precip ! Precipitation rate [kg/m²/s] + real, pointer, dimension(:) :: prev_dnmf ! Dndraft mass flux last time [kg/m²/s] + real, pointer, dimension(:) :: precip ! Precipitation rate [kg/m²/s] end type ensemble_vars @@ -230,6 +230,9 @@ subroutine alloc_ensemble(ensemble,nclouds,mgmzp,maxens_dyn,maxens_lsf,maxens_ef allocate (ensemble%outthil (mgmzp) ) allocate (ensemble%outco2 (mgmzp) ) + + allocate (ensemble%prev_dnmf ( 1) ) + allocate (ensemble%precip ( 1) ) return end subroutine alloc_ensemble !=======================================================================================! @@ -247,64 +250,67 @@ subroutine nullify_ensemble(ensemble) implicit none type(ensemble_vars) :: ensemble - if(associated(ensemble%dnmf_ens )) nullify(ensemble%dnmf_ens ) - if(associated(ensemble%upmf_ens )) nullify(ensemble%upmf_ens ) - if(associated(ensemble%dnmx_ens )) nullify(ensemble%dnmx_ens ) - if(associated(ensemble%upmx_ens )) nullify(ensemble%upmx_ens ) - - if(associated(ensemble%x_aatot )) nullify(ensemble%x_aatot ) - - if(associated(ensemble%edt_eff )) nullify(ensemble%edt_eff ) - if(associated(ensemble%aatot0_eff )) nullify(ensemble%aatot0_eff ) - if(associated(ensemble%aatot_eff )) nullify(ensemble%aatot_eff ) - - if(associated(ensemble%dellatheiv_eff )) nullify(ensemble%dellatheiv_eff ) - if(associated(ensemble%dellathil_eff )) nullify(ensemble%dellathil_eff ) - if(associated(ensemble%dellaqtot_eff )) nullify(ensemble%dellaqtot_eff ) - if(associated(ensemble%dellaco2_eff )) nullify(ensemble%dellaco2_eff ) - if(associated(ensemble%pw_eff )) nullify(ensemble%pw_eff ) - - if(associated(ensemble%ierr_cap )) nullify(ensemble%ierr_cap ) - if(associated(ensemble%comp_down_cap )) nullify(ensemble%comp_down_cap ) - if(associated(ensemble%klod_cap )) nullify(ensemble%klod_cap ) - if(associated(ensemble%klou_cap )) nullify(ensemble%klou_cap ) - if(associated(ensemble%klcl_cap )) nullify(ensemble%klcl_cap ) - if(associated(ensemble%klfc_cap )) nullify(ensemble%klfc_cap ) - if(associated(ensemble%kdet_cap )) nullify(ensemble%kdet_cap ) - if(associated(ensemble%kstabi_cap )) nullify(ensemble%kstabi_cap ) - if(associated(ensemble%kstabm_cap )) nullify(ensemble%kstabm_cap ) - if(associated(ensemble%klnb_cap )) nullify(ensemble%klnb_cap ) - if(associated(ensemble%ktop_cap )) nullify(ensemble%ktop_cap ) - if(associated(ensemble%pwav_cap )) nullify(ensemble%pwav_cap ) - if(associated(ensemble%pwev_cap )) nullify(ensemble%pwev_cap ) - if(associated(ensemble%dnmf_cap )) nullify(ensemble%dnmf_cap ) - if(associated(ensemble%upmf_cap )) nullify(ensemble%upmf_cap ) - if(associated(ensemble%areadn_cap )) nullify(ensemble%areadn_cap ) - if(associated(ensemble%areaup_cap )) nullify(ensemble%areaup_cap ) - if(associated(ensemble%wdndraft_cap )) nullify(ensemble%wdndraft_cap ) - if(associated(ensemble%wupdraft_cap )) nullify(ensemble%wupdraft_cap ) - if(associated(ensemble%wbuoymin_cap )) nullify(ensemble%wbuoymin_cap ) - - - if(associated(ensemble%cdd_cap )) nullify(ensemble%cdd_cap ) - if(associated(ensemble%cdu_cap )) nullify(ensemble%cdu_cap ) - if(associated(ensemble%mentrd_rate_cap)) nullify(ensemble%mentrd_rate_cap) - if(associated(ensemble%mentru_rate_cap)) nullify(ensemble%mentru_rate_cap) - if(associated(ensemble%dbyd_cap )) nullify(ensemble%dbyd_cap ) - if(associated(ensemble%dbyu_cap )) nullify(ensemble%dbyu_cap ) - if(associated(ensemble%etad_cld_cap )) nullify(ensemble%etad_cld_cap ) - if(associated(ensemble%etau_cld_cap )) nullify(ensemble%etau_cld_cap ) - if(associated(ensemble%rhod_cld_cap )) nullify(ensemble%rhod_cld_cap ) - if(associated(ensemble%rhou_cld_cap )) nullify(ensemble%rhou_cld_cap ) - if(associated(ensemble%qliqd_cld_cap )) nullify(ensemble%qliqd_cld_cap ) - if(associated(ensemble%qliqu_cld_cap )) nullify(ensemble%qliqu_cld_cap ) - if(associated(ensemble%qiced_cld_cap )) nullify(ensemble%qiced_cld_cap ) - if(associated(ensemble%qiceu_cld_cap )) nullify(ensemble%qiceu_cld_cap ) - - - if(associated(ensemble%outco2 )) nullify(ensemble%outco2 ) - if(associated(ensemble%outqtot )) nullify(ensemble%outqtot ) - if(associated(ensemble%outthil )) nullify(ensemble%outthil ) + nullify(ensemble%dnmf_ens ) + nullify(ensemble%upmf_ens ) + nullify(ensemble%dnmx_ens ) + nullify(ensemble%upmx_ens ) + + nullify(ensemble%x_aatot ) + + nullify(ensemble%edt_eff ) + nullify(ensemble%aatot0_eff ) + nullify(ensemble%aatot_eff ) + + nullify(ensemble%dellatheiv_eff ) + nullify(ensemble%dellathil_eff ) + nullify(ensemble%dellaqtot_eff ) + nullify(ensemble%dellaco2_eff ) + nullify(ensemble%pw_eff ) + + nullify(ensemble%ierr_cap ) + nullify(ensemble%comp_down_cap ) + nullify(ensemble%klod_cap ) + nullify(ensemble%klou_cap ) + nullify(ensemble%klcl_cap ) + nullify(ensemble%klfc_cap ) + nullify(ensemble%kdet_cap ) + nullify(ensemble%kstabi_cap ) + nullify(ensemble%kstabm_cap ) + nullify(ensemble%klnb_cap ) + nullify(ensemble%ktop_cap ) + nullify(ensemble%pwav_cap ) + nullify(ensemble%pwev_cap ) + nullify(ensemble%dnmf_cap ) + nullify(ensemble%upmf_cap ) + nullify(ensemble%areadn_cap ) + nullify(ensemble%areaup_cap ) + nullify(ensemble%wdndraft_cap ) + nullify(ensemble%wupdraft_cap ) + nullify(ensemble%wbuoymin_cap ) + + + nullify(ensemble%cdd_cap ) + nullify(ensemble%cdu_cap ) + nullify(ensemble%mentrd_rate_cap) + nullify(ensemble%mentru_rate_cap) + nullify(ensemble%dbyd_cap ) + nullify(ensemble%dbyu_cap ) + nullify(ensemble%etad_cld_cap ) + nullify(ensemble%etau_cld_cap ) + nullify(ensemble%rhod_cld_cap ) + nullify(ensemble%rhou_cld_cap ) + nullify(ensemble%qliqd_cld_cap ) + nullify(ensemble%qliqu_cld_cap ) + nullify(ensemble%qiced_cld_cap ) + nullify(ensemble%qiceu_cld_cap ) + + + nullify(ensemble%outco2 ) + nullify(ensemble%outqtot ) + nullify(ensemble%outthil ) + + nullify(ensemble%prev_dnmf ) + nullify(ensemble%precip ) return end subroutine nullify_ensemble @@ -382,6 +388,9 @@ subroutine dealloc_ensemble(ensemble) if(associated(ensemble%outqtot )) deallocate(ensemble%outqtot ) if(associated(ensemble%outthil )) deallocate(ensemble%outthil ) + if(associated(ensemble%prev_dnmf )) deallocate(ensemble%prev_dnmf ) + if(associated(ensemble%precip )) deallocate(ensemble%precip ) + return end subroutine dealloc_ensemble !=======================================================================================! @@ -459,8 +468,8 @@ subroutine zero_ensemble(ensemble) if(associated(ensemble%outthil )) ensemble%outthil = 0. !----- Real variables ----------------------------------------------------------------! - ensemble%prev_dnmf = 0. - ensemble%precip = 0. + if(associated(ensemble%prev_dnmf )) ensemble%prev_dnmf = 0. + if(associated(ensemble%precip )) ensemble%precip = 0. !-------------------------------------------------------------------------------------! return diff --git a/BRAMS/src/cuparm/mem_scratch_grell.f90 b/BRAMS/src/cuparm/mem_scratch_grell.f90 index 13dfcb94e..14bd9c6f1 100644 --- a/BRAMS/src/cuparm/mem_scratch_grell.f90 +++ b/BRAMS/src/cuparm/mem_scratch_grell.f90 @@ -35,6 +35,7 @@ module mem_scratch_grell ,qvapsur & ! Surface: mixing ratio [ kg/kg] ,qliqsur & ! Surface: mixing ratio [ kg/kg] ,qicesur & ! Surface: mixing ratio [ kg/kg] + ,rhosur & ! Surface: air density [ kg/m³] ,tsur & ! Surface: temperature [ K] ,theivsur & ! Surface: ice-vapour equivalent potential temperature [ K] ,thilsur ! ! Surface: ice-liquid potential temperature [ K] diff --git a/BRAMS/src/cuparm/rconv_driver.f90 b/BRAMS/src/cuparm/rconv_driver.f90 index 48ab4c795..1c37c574e 100644 --- a/BRAMS/src/cuparm/rconv_driver.f90 +++ b/BRAMS/src/cuparm/rconv_driver.f90 @@ -180,7 +180,7 @@ logical function cumulus_time(initial,time,cptime,confrq,deltat) cumulus_time = (.not. (initial == 2 .and. time < cptime - dble(deltat))) .and. & - mod(time,confrq) < deltat + mod(time,dble(confrq)) < dble(deltat) return end function cumulus_time diff --git a/BRAMS/src/cuparm/shcu_vars_const.f90 b/BRAMS/src/cuparm/shcu_vars_const.f90 index f0ba0ece1..5fb42f39f 100644 --- a/BRAMS/src/cuparm/shcu_vars_const.f90 +++ b/BRAMS/src/cuparm/shcu_vars_const.f90 @@ -30,6 +30,6 @@ module shcu_vars_const ! COMMON/SHCTES/ real, parameter :: CPR=3.4965, CP=1004., P00=1E5, RCP=.286, & - ALVL=2.5E6, ALIV=2.834E6, AKLV=2340.6, AKIV=2825.7, G=9.8, R=287. + ALVL3=2.5E6, ALIV=2.834E6, AKLV=2340.6, AKIV=2825.7, G=9.8, R=287. end module shcu_vars_const diff --git a/BRAMS/src/cuparm/souza_cupar_driver.f90 b/BRAMS/src/cuparm/souza_cupar_driver.f90 index c417b8baa..47af17596 100644 --- a/BRAMS/src/cuparm/souza_cupar_driver.f90 +++ b/BRAMS/src/cuparm/souza_cupar_driver.f90 @@ -205,7 +205,7 @@ subroutine shcu_env(nz) p00, & ! intent(in) ! parameter r, & ! intent(in) ! parameter kzi, & ! intent(out) ! maybe local var.? - alvl, & ! intent(in) ! parameter + alvl3, & ! intent(in) ! parameter akvde ! intent(in/out) use therm_lib, only : lcl_il implicit none @@ -298,7 +298,7 @@ subroutine shcu_env(nz) rlll = (qve(kcon)+qve(kcon-1))/2. zlll = ze(kcon) thlll = tlll*(p00/plll)**(r/cp) - call lcl_il(thlll,plll,tlll,rlll,rlll,tlcl,plcl,dzlcl,2,.false.) + call lcl_il(thlll,plll,tlll,rlll,rlll,tlcl,plcl,dzlcl,.false.) if (dzlcl == 0.) then tlcl = tlll plcl = plll @@ -333,10 +333,10 @@ subroutine shcu_env(nz) !----- EPS - Determination of environment variables ------------------------------------! do k=1,kmt dse(k) = cp*te(k)+g*ze(k) - uhe(k) = dse(k)+alvl*qve(k) + uhe(k) = dse(k)+alvl3*qve(k) evaps(k) = es00*exp(const3*(te(k)-ta0)/(te(k)-const2)) qvse(k) = epslon*evaps(k)/(pe(k)-ummeps*evaps(k)) - uhes(k) = dse(k)+alvl*qvse(k) + uhes(k) = dse(k)+alvl3*qvse(k) rhe(k) = qve(k)/qvse(k) gamma(k) = const1*pe(k)*qvse(k)**2/evaps(k) gamma(k) = gamma(k)/((te(k)-const2)*(te(k)-const2)) @@ -376,7 +376,7 @@ subroutine shcu_env(nz) do k=1,kmt dsc(k) = dse(k)+(uhc(k)-uhes(k))/(1+gamma(k)) dsc0(k) = dse(k)+(uhe(2)-uhes(k))/(1+gamma(k)) - qvc(k) = qvse(k)+gamma(k)*(uhc(k)-uhes(k))/(alvl*(1+gamma(k))) + qvc(k) = qvse(k)+gamma(k)*(uhc(k)-uhes(k))/(alvl3*(1+gamma(k))) wlc(k) = 0.0 end do @@ -415,7 +415,7 @@ subroutine sh2mod(m1) picon ! intent(in) use shcu_vars_const, only : & DTDT, & ! intent(in/out) - ALVL, & ! intent(in) ! parameter + ALVL3, & ! intent(in) ! parameter DRDT ! intent(in/out) use mem_scratch, only : VCTR5, & ! INTENT(IN/OUT) @@ -434,7 +434,7 @@ subroutine sh2mod(m1) !----- Compute integrated heating and moistening tendencies ----------------------------! do k=2,kmt qvct1(k) = rhoe(k)*dtdt(k)*pke(k) - qvct2(k) = rhoe(k)*alvl*drdt(k) + qvct2(k) = rhoe(k)*alvl3*drdt(k) qvct3(k) = (zc(k)-zc(k-1))*qvct1(k) qvct4(k) = (zc(k)-zc(k-1))*qvct2(k) end do @@ -464,7 +464,7 @@ subroutine sh2mod(m1) !----- Change energy tendencies to temperature and mixing ratio tendencies. ------------! do k=2,m1-1 dtdt(k)=vctr5(k)/((zzcon(k)-zzcon(k-1))*dncon(k)*picon(k)) - drdt(k)=vctr6(k)/((zzcon(k)-zzcon(k-1))*dncon(k)*alvl) + drdt(k)=vctr6(k)/((zzcon(k)-zzcon(k-1))*dncon(k)*alvl3) end do return @@ -612,7 +612,7 @@ subroutine W_SHALLOW(IP,JP,TIME) cape, & ! intent(in) cp, & ! intent(in) entf, & ! intent(in) ! parameter - alvl, & ! intent(in) ! parameter + alvl3, & ! intent(in) ! parameter alhf, & ! intent(in) dcape, & ! intent(out) ! maybe local var.? tcape, & ! intent(out) ! maybe local var.? @@ -652,7 +652,7 @@ subroutine W_SHALLOW(IP,JP,TIME) ! The effective vertical velocity at cloud base is calculated according to the heat ! ! engine framework as deffined by Renno' and Ingersoll, 1996 Eq.(34) ! !---------------------------------------------------------------------------------------! - fin=rhoe(2)*(cp*entf+alvl*alhf) + fin=rhoe(2)*(cp*entf+alvl3*alhf) if(fin <= 50.0) then igo=0 @@ -704,7 +704,7 @@ subroutine SH_RATES ktop, & ! intent(in) wc, & ! intent(in/out) dsc, & ! intent(in) - alvl, & ! intent(in) ! parameter + alvl3, & ! intent(in) ! parameter wlc, & ! intent(in) dse, & ! intent(in) qvc, & ! intent(in) @@ -731,7 +731,7 @@ subroutine SH_RATES !----- Calculating the transports w's' and w'r' ----------------------------------------! do k=klcl+1,ktop - wssc(k) = wc(k)*(dsc(k)-alvl*wlc(k)-dse(k)) + wssc(k) = wc(k)*(dsc(k)-alvl3*wlc(k)-dse(k)) wqsc(k) = wc(k)*(qvc(k)+wlc(k)-qve(k)) end do diff --git a/BRAMS/src/ed2/edcp_driver.f90 b/BRAMS/src/ed2/edcp_driver.f90 index 399b01964..87cd4bf05 100644 --- a/BRAMS/src/ed2/edcp_driver.f90 +++ b/BRAMS/src/ed2/edcp_driver.f90 @@ -19,6 +19,7 @@ subroutine ed_coup_driver() , idoutput & ! intent(in) , imoutput & ! intent(in) , iqoutput & ! intent(in) + , isoutput & ! intent(in) , iyoutput & ! intent(in) , runtype ! ! intent(in) use ed_work_vars , only : ed_dealloc_work & ! subroutine @@ -30,6 +31,7 @@ subroutine ed_coup_driver() , recvnum ! ! intent(in) use io_params , only : ioutput ! ! intent(in) use rk4_coms , only : checkbudget ! ! intent(in) + use phenology_aux , only : first_phenology ! ! subroutine implicit none !----- Local variables. ----------------------------------------------------------------! character(len=12) :: c0 @@ -89,7 +91,7 @@ subroutine ed_coup_driver() !---------------------------------------------------------------------------------------! if (mynum /= 1) call MPI_Recv(ping,1,MPI_INTEGER,recvnum,91,MPI_COMM_WORLD & ,MPI_STATUS_IGNORE,ierr) - if (mynum == 1) write (unit=*,fmt='(a)') ' [+] Checking for XML config...' + if (mynum == nnodetot) write (unit=*,fmt='(a)') ' [+] Checking for XML config...' call overwrite_with_xml_config(mynum) if (mynum < nnodetot ) call MPI_Send(ping,1,MPI_INTEGER,sendnum,91,MPI_COMM_WORLD,ierr) @@ -121,7 +123,7 @@ subroutine ed_coup_driver() if (mynum /= 1) call MPI_Recv(ping,1,MPI_INTEGER,recvnum,90,MPI_COMM_WORLD & ,MPI_STATUS_IGNORE,ierr) - if (mynum == 1) write (unit=*,fmt='(a)') ' [+] Init_Full_History_Restart...' + if (mynum == nnodetot) write (unit=*,fmt='(a)') ' [+] Init_Full_History_Restart...' call init_full_history_restart() if (mynum < nnodetot ) call MPI_Send(ping,1,MPI_INTEGER,sendnum,90,MPI_COMM_WORLD & @@ -131,21 +133,21 @@ subroutine ed_coup_driver() !------------------------------------------------------------------------------------! ! Initialize state properties of polygons/sites/patches/cohorts. ! !------------------------------------------------------------------------------------! - if (mynum == 1) write (unit=*,fmt='(a)') ' [+] Load_Ecosystem_State...' + if (mynum == nnodetot) write (unit=*,fmt='(a)') ' [+] Load_Ecosystem_State...' call load_ecosystem_state() end if !---------------------------------------------------------------------------------------! ! Initialize hydrology related variables. ! !---------------------------------------------------------------------------------------! - if (mynum == 1) write (unit=*,fmt='(a)') ' [+] Initializing Hydrology...' + if (mynum == nnodetot) write (unit=*,fmt='(a)') ' [+] Initializing Hydrology...' call initHydrology() !---------------------------------------------------------------------------------------! ! Initialize the flux arrays that pass to the atmosphere. ! !---------------------------------------------------------------------------------------! - if (mynum == 1) write (unit=*,fmt='(a)') ' [+] Initialise flux arrays...' + if (mynum == nnodetot) write (unit=*,fmt='(a)') ' [+] Initialise flux arrays...' do ifm=1,ngrids call newgrid(ifm) call initialize_ed2leaf(ifm) @@ -164,13 +166,18 @@ subroutine ed_coup_driver() ! Initialize ed fields that depend on the atmosphere. ! !---------------------------------------------------------------------------------------! if (trim(runtype) /= 'HISTORY') then - if (mynum == nnodetot) write (unit=*,fmt='(a)') ' [+] ed_init_atm...' + if (mynum == nnodetot) then + write (unit=*,fmt='(a)') ' [+] Initialise atmospheric fields...' + end if call ed_init_atm() end if !---------------------------------------------------------------------------------------! ! Initialize upwelling long wave and albedo from sst and air temperature. ! !---------------------------------------------------------------------------------------! + if (mynum == nnodetot) then + write (unit=*,fmt='(a)') ' [+] Initialise radiation...' + end if call ed_init_radiation() @@ -179,6 +186,9 @@ subroutine ed_coup_driver() ! init_full_history_restart because it depends on some meteorological variables that ! ! are initialized in ed_init_atm. ! !---------------------------------------------------------------------------------------! + if (mynum == nnodetot) then + write (unit=*,fmt='(a)') ' [+] Initialise derived properties...' + end if do ifm=1,ngrids call update_derived_props(edgrid_g(ifm)) end do @@ -191,6 +201,7 @@ subroutine ed_coup_driver() ! been set up. ! !---------------------------------------------------------------------------------------! if (trim(runtype) /= 'HISTORY') then + if (mynum == nnodetot) write (unit=*,fmt='(a)') ' [+] Initialise phenology...' do ifm=1,ngrids call first_phenology(edgrid_g(ifm)) end do @@ -204,14 +215,14 @@ subroutine ed_coup_driver() ! the indexing of the vectors to allow for segmented I/O of hyperslabs and referencing ! ! of high level hierarchical data types with their parent types. ! !---------------------------------------------------------------------------------------! - if (mynum == 1) write (unit=*,fmt='(a)') ' [+] Filltab_Alltypes...' + if (mynum == nnodetot) write (unit=*,fmt='(a)') ' [+] Filltab_Alltypes...' call filltab_alltypes() !---------------------------------------------------------------------------------------! ! Check how the output was configure and determining the averaging frequency. ! !---------------------------------------------------------------------------------------! - if (mynum == 1) write(unit=*,fmt='(a)') ' [+] Finding frqsum...' + if (mynum == nnodetot) write(unit=*,fmt='(a)') ' [+] Finding frqsum...' call find_frqsum() !---------------------------------------------------------------------------------------! @@ -220,17 +231,20 @@ subroutine ed_coup_driver() !---------------------------------------------------------------------------------------! if (trim(runtype) /= 'HISTORY') then if (imoutput > 0 .or. iqoutput > 0) then + if (mynum == nnodetot) write(unit=*,fmt='(a)') ' [+] Reset monthly means...' do ifm=1,ngrids call zero_ed_monthly_output_vars(edgrid_g(ifm)) call zero_ed_daily_output_vars(edgrid_g(ifm)) end do elseif (idoutput > 0) then + if (mynum == nnodetot) write(unit=*,fmt='(a)') ' [+] Reset daily means...' do ifm=1,ngrids call zero_ed_daily_output_vars(edgrid_g(ifm)) end do end if !----- Output Initial State. --------------------------------------------------------! + if (mynum == nnodetot) write(unit=*,fmt='(a)') ' [+] Update annual means...' do ifm=1,ngrids call update_ed_yearly_vars(edgrid_g(ifm)) end do @@ -239,8 +253,10 @@ subroutine ed_coup_driver() !---------------------------------------------------------------------------------------! ! Allocate memory to the integration patch. ! !---------------------------------------------------------------------------------------! + if (mynum == nnodetot) write(unit=*,fmt='(a)') ' [+] Initialise RK4 patches...' call initialize_rk4patches(.true.) + if (mynum == nnodetot) write(unit=*,fmt='(a)') ' [+] Reset averaged variables...' do ifm=1,ngrids call reset_averaged_vars(edgrid_g(ifm)) end do @@ -249,8 +265,9 @@ subroutine ed_coup_driver() !---------------------------------------------------------------------------------------! ! Output initial state. ! !---------------------------------------------------------------------------------------! - if (ioutput /= 0) then - call h5_output('INST') + if (mynum == nnodetot) write(unit=*,fmt='(a)') ' [+] Output initial state...' + if (ifoutput /= 0) call h5_output('INST') + if (isoutput /= 0) then select case (trim(runtype)) case ('INITIAL') call h5_output('HIST') @@ -263,6 +280,7 @@ subroutine ed_coup_driver() !---------------------------------------------------------------------------------------! ! Deallocate the work arrays. ! !---------------------------------------------------------------------------------------! + if (mynum == nnodetot) write(unit=*,fmt='(a)') ' [+] Deallocate work arrays...' do ifm=1,ngrids call ed_dealloc_work(work_e(ifm)) end do @@ -270,6 +288,7 @@ subroutine ed_coup_driver() !---------------------------------------------------------------------------------------! ! Get the CPU time and print the banner. ! !---------------------------------------------------------------------------------------! + if (mynum == nnodetot) write(unit=*,fmt='(a)') ' [+] Get CPU time...' if (mynum == nnodetot) then call timing(1,cputime1) wtime2=walltime(wtime_start) diff --git a/BRAMS/src/ed2/edcp_lake_driver.f90 b/BRAMS/src/ed2/edcp_lake_driver.f90 index d659a1fcf..47642ab7e 100644 --- a/BRAMS/src/ed2/edcp_lake_driver.f90 +++ b/BRAMS/src/ed2/edcp_lake_driver.f90 @@ -12,17 +12,10 @@ subroutine simple_lake_model() , iz & ! intent(in) , mynum ! ! intent(in) use consts_coms , only : stefan & ! intent(in) - , cpi & ! intent(in) , vonk & ! intent(in) - , cp & ! intent(in) , grav & ! intent(in) , rdry & ! intent(in) , t00 & ! intent(in) - , p00 & ! intent(in) - , p00i & ! intent(in) - , rocp & ! intent(in) - , cpor & ! intent(in) - , alvl & ! intent(in) , epim1 & ! intent(in) , mmdryi & ! intent(in) , mmdry ! ! intent(in) @@ -182,6 +175,7 @@ subroutine copy_met_2_lake(i,j,ifm,dsst_dt) use mem_basic , only : co2_on & ! intent(in) , co2con & ! intent(in) , basic_g ! ! structure + use mem_leaf , only : leaf_g ! ! intent(in) use mem_radiate , only : radiate_g ! ! structure use mem_grid , only : zt & ! intent(in) , grid_g & ! structure @@ -190,15 +184,16 @@ subroutine copy_met_2_lake(i,j,ifm,dsst_dt) , if_adap & ! intent(in) , jdim & ! intent(in) , ngrid ! ! intent(in) - use therm_lib8 , only : thetaeiv8 & ! function - , idealdenssh8 & ! function - , rehuil8 ! ! function + use therm_lib8 , only : idealdenssh8 & ! function + , rehuil8 & ! function + , reducedpress8 & ! function + , press2exner8 & ! function + , exner2press8 & ! function + , extheta2temp8 & ! function + , tq2enthalpy8 ! ! function use lake_coms , only : lakemet ! ! intent(out) - use consts_coms , only : cpi8 & ! intent(in) - , p00i8 & ! intent(in) - , p008 & ! intent(in) - , cpor8 ! ! intent(in) use canopy_air_coms , only : ubmin8 ! ! intent(in) + use leaf_coms , only : can_depth_min ! ! intent(in) implicit none !----- Arguments. ----------------------------------------------------------------------! integer , intent(in) :: i @@ -218,20 +213,25 @@ subroutine copy_met_2_lake(i,j,ifm,dsst_dt) integer :: k2v_1 integer :: k3v_1 logical :: ok_flpoint - real :: topma_t - real :: wtw - real :: wtu1 - real :: wtu2 - real :: wtv1 - real :: wtv2 - real :: exner_mean - real :: theta_mean - real :: co2p_mean - real :: up_mean - real :: vp_mean - real :: rv_mean - real :: rtp_mean - real :: zref_mean + real(kind=4) :: topma_t + real(kind=4) :: wtw + real(kind=4) :: wtu1 + real(kind=4) :: wtu2 + real(kind=4) :: wtv1 + real(kind=4) :: wtv2 + real(kind=4) :: exner_mean + real(kind=4) :: theta_mean + real(kind=4) :: co2p_mean + real(kind=4) :: up_mean + real(kind=4) :: vp_mean + real(kind=4) :: rv_mean + real(kind=4) :: rtp_mean + real(kind=4) :: zref_mean + real(kind=8) :: can_theta8 + real(kind=8) :: can_shv8 + real(kind=8) :: can_depth8 + real(kind=8) :: can_exner8 + real(kind=8) :: can_prss8 real(kind=8) :: angle !----- External functions. -------------------------------------------------------------! logical , external :: is_finite @@ -413,14 +413,11 @@ subroutine copy_met_2_lake(i,j,ifm,dsst_dt) lakemet%atm_theta = dble(theta_mean) lakemet%atm_co2 = dble(co2p_mean ) lakemet%atm_exner = dble(exner_mean) - lakemet%atm_rvap = dble(rtp_mean ) + lakemet%atm_shv = dble(rtp_mean ) / (1.d0 + dble(rtp_mean)) !----- SST derivative is already in double precision, just copy it. --------------------! lakemet%dsst_dt = dsst_dt !---------------------------------------------------------------------------------------! - - - - + @@ -431,7 +428,7 @@ subroutine copy_met_2_lake(i,j,ifm,dsst_dt) is_finite8(lakemet%tanz) .and. is_finite8(lakemet%lon) .and. & is_finite8(lakemet%lat) .and. is_finite8(lakemet%geoht) .and. & is_finite8(lakemet%atm_theta) .and. is_finite8(lakemet%atm_co2) .and. & - is_finite8(lakemet%atm_exner) .and. is_finite8(lakemet%atm_rvap) .and. & + is_finite8(lakemet%atm_exner) .and. is_finite8(lakemet%atm_shv) .and. & is_finite8(lakemet%dsst_dt) .and. is_finite (exner_mean) .and. & is_finite (theta_mean) .and. is_finite (co2p_mean) .and. & is_finite (up_mean) .and. is_finite (vp_mean) .and. & @@ -451,7 +448,7 @@ subroutine copy_met_2_lake(i,j,ifm,dsst_dt) write(unit=*,fmt='(a,1x,es12.5)') ' - Theta :',lakemet%atm_theta write(unit=*,fmt='(a,1x,es12.5)') ' - CO2 :',lakemet%atm_co2 write(unit=*,fmt='(a,1x,es12.5)') ' - Exner :',lakemet%atm_exner - write(unit=*,fmt='(a,1x,es12.5)') ' - Rvap :',lakemet%atm_rvap + write(unit=*,fmt='(a,1x,es12.5)') ' - Spec. hum. :',lakemet%atm_shv write(unit=*,fmt='(a,1x,es12.5)') ' - d(SST)/dt :',lakemet%dsst_dt write(unit=*,fmt='(a)' ) ' Mean values.' write(unit=*,fmt='(a,1x,es12.5)') ' - Exner_mean :',exner_mean @@ -498,32 +495,42 @@ subroutine copy_met_2_lake(i,j,ifm,dsst_dt) write(unit=*,fmt='(a)' ) '-------------------------------------------------' call abort_run('Non-resolvable values','copy_met_2_lake','edcp_lake_misc.f90') end if + !---------------------------------------------------------------------------------------! - !----- Log of potential temperature. ---------------------------------------------------! - lakemet%atm_lntheta = log(lakemet%atm_theta) + !---------------------------------------------------------------------------------------! + ! Copy the canopy air space properties to double precision scratch variables. ! + !---------------------------------------------------------------------------------------! + can_theta8 = dble(leaf_g(ifm)%can_theta(i,j,1)) + can_shv8 = dble(leaf_g(ifm)%can_rvap (i,j,1)) & + / (1.d0 +dble(leaf_g(ifm)%can_rvap (i,j,1))) + can_depth8 = dble(can_depth_min) !---------------------------------------------------------------------------------------! !----- Pressure. -----------------------------------------------------------------------! - lakemet%atm_prss = (lakemet%atm_exner * cpi8) ** cpor8 * p008 + lakemet%atm_prss = exner2press8(lakemet%atm_exner) !---------------------------------------------------------------------------------------! !----- Air temperature. ----------------------------------------------------------------! - lakemet%atm_tmp = cpi8 * lakemet%atm_theta * lakemet%atm_exner + lakemet%atm_tmp = extheta2temp8(lakemet%atm_exner,lakemet%atm_theta) !---------------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------------! - ! Most of ED expects specific humidity, not mixing ratio. Since we will use ! - ! ed_stars, which is set up for the former, not the latter, we locally solve everything ! - ! for specific humidity, converting in the end. ! + ! Find the pressure and Exner functions at the canopy depth, find the temperature ! + ! of the air above canopy at the canopy depth, and the specific enthalpy at that level. ! !---------------------------------------------------------------------------------------! - lakemet%atm_shv = lakemet%atm_rvap / (1.d0 + lakemet%atm_rvap) + can_prss8 = reducedpress8(lakemet%atm_prss,lakemet%atm_theta,lakemet%atm_shv & + ,lakemet%geoht,can_theta8,can_shv8,can_depth8) + can_exner8 = press2exner8 (can_prss8) + lakemet%atm_tmp_zcan = extheta2temp8(can_exner8,lakemet%atm_theta) + lakemet%atm_enthalpy = tq2enthalpy8 (lakemet%atm_tmp_zcan,lakemet%atm_shv,.true.) !---------------------------------------------------------------------------------------! @@ -531,10 +538,9 @@ subroutine copy_met_2_lake(i,j,ifm,dsst_dt) !---------------------------------------------------------------------------------------! ! Update properties that need to use therm_lib8. ! !---------------------------------------------------------------------------------------! - lakemet%atm_theiv = thetaeiv8(lakemet%atm_theta,lakemet%atm_prss,lakemet%atm_tmp & - ,lakemet%atm_rvap,lakemet%atm_rvap) lakemet%atm_rhos = idealdenssh8(lakemet%atm_prss,lakemet%atm_tmp,lakemet%atm_shv) - lakemet%atm_rhv = rehuil8(lakemet%atm_prss,lakemet%atm_tmp,lakemet%atm_rvap) + lakemet%atm_rhv = rehuil8(lakemet%atm_prss,lakemet%atm_tmp,lakemet%atm_shv,.true.) + !---------------------------------------------------------------------------------------! !---------------------------------------------------------------------------------------! @@ -566,15 +572,17 @@ subroutine copy_lake_brams(i,j,ifm,mzg,mzs,initp) use mem_radiate , only : radiate_g ! ! structure use mem_leaf , only : leaf_g ! ! structure use lake_coms , only : lakemet ! ! intent(out) - use consts_coms , only : alvl8 & ! intent(in) - , cliq8 & ! intent(in) - , tsupercool8 & ! intent(in) - , cliq & ! intent(in) - , grav ! ! intent(in) + use consts_coms , only : grav ! ! intent(in) use canopy_air_coms , only : ubmin8 ! ! intent(in) use lake_coms , only : lakesitetype & ! structure , lakemet & ! intent(in) , tiny_lakeoff ! ! intent(in) + use therm_lib , only : thetaeiv & ! function + , press2exner & ! function + , extheta2temp ! ! function + use therm_lib8 , only : alvl8 & ! function + , alvi8 & ! function + , tl2uint8 ! ! function use mem_edcp , only : ed_fluxf_g ! ! intent(in) implicit none !----- Arguments. ----------------------------------------------------------------------! @@ -586,6 +594,9 @@ subroutine copy_lake_brams(i,j,ifm,mzg,mzs,initp) type(lakesitetype), target :: initp !----- Local variables. ----------------------------------------------------------------! integer :: k + real :: can_shv + real :: can_exner + real :: can_temp !----- External functions. -------------------------------------------------------------! real , external :: sngloff !----- Local constants -----------------------------------------------------------------! @@ -633,7 +644,11 @@ subroutine copy_lake_brams(i,j,ifm,mzg,mzs,initp) !----- Find the flux components of each patch. -----------------------------------------! leaf_g(ifm)%sensible_gc(i,j,1) = sngloff(initp%avg_sensible_gc ,tiny_lakeoff) - leaf_g(ifm)%evap_gc(i,j,1) = sngloff(initp%avg_vapor_gc * alvl8 ,tiny_lakeoff) + leaf_g(ifm)%evap_gc(i,j,1) = sngloff( initp%avg_vapor_gc & + * ( initp%lake_fliq * alvl8(initp%lake_temp) & + + (1.d0 - initp%lake_fliq) & + * alvi8(initp%lake_temp)) & + , tiny_lakeoff ) leaf_g(ifm)%sensible_vc(i,j,1) = 0. leaf_g(ifm)%evap_vc(i,j,1) = 0. leaf_g(ifm)%transp(i,j,1) = 0. @@ -644,11 +659,18 @@ subroutine copy_lake_brams(i,j,ifm,mzg,mzs,initp) !----- Finding some canopy air properties. ---------------------------------------------! - leaf_g(ifm)%can_theiv(i,j,1) = sngloff(initp%can_theiv ,tiny_lakeoff) leaf_g(ifm)%can_theta(i,j,1) = sngloff(initp%can_theta ,tiny_lakeoff) - leaf_g(ifm)%can_rvap(i,j,1) = sngloff(initp%can_rvap ,tiny_lakeoff) + can_shv = sngloff(initp%can_shv ,tiny_lakeoff) + leaf_g(ifm)%can_rvap(i,j,1) = can_shv / (1.0 - can_shv) leaf_g(ifm)%can_co2(i,j,1) = sngloff(initp%can_co2 ,tiny_lakeoff) leaf_g(ifm)%can_prss(i,j,1) = sngloff(initp%can_prss ,tiny_lakeoff) + can_exner = press2exner(leaf_g(ifm)%can_prss(i,j,1)) + can_temp = extheta2temp(can_exner,leaf_g(ifm)%can_theta(i,j,1)) + leaf_g(ifm)%can_theiv(i,j,1) = thetaeiv( leaf_g(ifm)%can_theta(i,j,1) & + , leaf_g(ifm)%can_prss(i,j,1) & + , can_temp & + , leaf_g(ifm)%can_rvap(i,j,1) & + , leaf_g(ifm)%can_rvap(i,j,1) ) !---------------------------------------------------------------------------------------! @@ -692,8 +714,8 @@ subroutine copy_lake_brams(i,j,ifm,mzg,mzs,initp) ! "Soil" energy. Because we can't store sea surface temperature, we store the ! ! internal energy !---------------------------------------------------------------------------------------! - leaf_g(ifm)%soil_energy (mzg,i,j,1) = sngloff(cliq8 * (initp%lake_temp - tsupercool8) & - ,tiny_lakeoff) + leaf_g(ifm)%soil_energy (mzg,i,j,1) = sngloff(tl2uint8(initp%lake_temp,initp%lake_fliq) & + ,tiny_lakeoff) leaf_g(ifm)%soil_water (mzg,i,j,1) = 0. do k=1, mzg-1 leaf_g(ifm)%soil_energy (k,i,j,1) = leaf_g(ifm)%soil_energy (mzg,i,j,1) diff --git a/BRAMS/src/ed2/edcp_lake_misc.f90 b/BRAMS/src/ed2/edcp_lake_misc.f90 index da0f980d7..907606ca7 100644 --- a/BRAMS/src/ed2/edcp_lake_misc.f90 +++ b/BRAMS/src/ed2/edcp_lake_misc.f90 @@ -5,24 +5,25 @@ subroutine copy_lake_init(i,j,ifm,initp) use lake_coms , only : lakesitetype & ! structure , lakemet & ! intent(in) , wcapcan & ! intent(in) + , hcapcan & ! intent(in) + , ccapcan & ! intent(in) , wcapcani & ! intent(in) , hcapcani & ! intent(in) , ccapcani ! ! intent(in) - use consts_coms , only : cp8 & ! intent(in) - , cpi8 & ! intent(in) - , p00i8 & ! intent(in) - , rocp8 ! ! intent(in) use therm_lib8 , only : reducedpress8 & ! function , thetaeiv8 & ! function , idealdenssh8 & ! function , rehuil8 & ! function - , rslif8 ! ! function + , qslif8 & ! function + , press2exner8 & ! function + , extheta2temp8 & ! function + , tq2enthalpy8 ! ! function use leaf_coms , only : min_waterrough8 & ! intent(in) , z0fac_water8 & ! intent(in) , can_depth_min ! ! intent(in) use canopy_air_coms , only : ustmin8 ! ! intent(in) use canopy_struct_dynamics, only : ed_stars8 & ! intent(in) - , can_whcap8 ! ! intent(in) + , can_whccap8 ! ! intent(in) implicit none !----- Arguments. ----------------------------------------------------------------------! integer , intent(in) :: i @@ -35,39 +36,49 @@ subroutine copy_lake_init(i,j,ifm,initp) !------ First we copy those variables that do not change with pressure. ----------------! - initp%can_co2 = dble(leaf_g(ifm)%can_co2 (i,j,1)) - initp%can_theta = dble(leaf_g(ifm)%can_theta(i,j,1)) - initp%can_theiv = dble(leaf_g(ifm)%can_theiv(i,j,1)) - initp%can_rvap = dble(leaf_g(ifm)%can_rvap (i,j,1)) - initp%can_depth = dble(can_depth_min) + initp%can_co2 = dble(leaf_g(ifm)%can_co2 (i,j,1)) + initp%can_theta = dble(leaf_g(ifm)%can_theta(i,j,1)) + initp%can_shv = dble(leaf_g(ifm)%can_rvap (i,j,1)) & + / (1.d0 + dble(leaf_g(ifm)%can_rvap (i,j,1))) + initp%can_depth = dble(can_depth_min) - !------ Convert mixing ratio to specific humidity. -------------------------------------! - initp%can_shv = initp%can_rvap / (1.d0 + initp%can_rvap) - - !------ Find the derived properties. ---------------------------------------------------! - initp%can_lntheta = log(initp%can_theta) + !---------------------------------------------------------------------------------------! + ! Update the canopy pressure and Exner function. ! + !---------------------------------------------------------------------------------------! + initp%can_prss = reducedpress8(lakemet%atm_prss,lakemet%atm_theta,lakemet%atm_shv & + ,lakemet%geoht,initp%can_theta,initp%can_shv & + ,initp%can_depth) + initp%can_exner = press2exner8 (initp%can_prss) + !---------------------------------------------------------------------------------------! - initp%can_prss = reducedpress8(lakemet%atm_prss,lakemet%atm_theta,lakemet%atm_shv & - ,lakemet%geoht,initp%can_theta,initp%can_shv & - ,initp%can_depth) - initp%can_exner = cp8 * (initp%can_prss * p00i8) ** rocp8 + !---------------------------------------------------------------------------------------! + ! Initialise canopy air temperature and enthalpy. Enthalpy is the actual ! + ! prognostic variable within one time step. ! + !---------------------------------------------------------------------------------------! + initp%can_temp = extheta2temp8(initp%can_exner,initp%can_theta) + initp%can_enthalpy = tq2enthalpy8(initp%can_temp,initp%can_shv,.true.) + !---------------------------------------------------------------------------------------! - initp%can_temp = cpi8 * initp%can_theta * initp%can_exner - initp%can_rhos = idealdenssh8(initp%can_prss,initp%can_temp,initp%can_shv) - initp%can_rhv = rehuil8(initp%can_prss,initp%can_temp,initp%can_rvap) - initp%can_ssh = rslif8(initp%can_prss,initp%can_temp) - initp%can_ssh = initp%can_ssh / (initp%can_ssh + 1.d0) + !---------------------------------------------------------------------------------------! + ! Update density, relative humidity, and the saturation specific humidity. ! + !---------------------------------------------------------------------------------------! + initp%can_rhos = idealdenssh8(initp%can_prss,initp%can_temp,initp%can_shv) + initp%can_rhv = rehuil8(initp%can_prss,initp%can_temp,initp%can_shv,.true.) + initp%can_ssh = qslif8(initp%can_prss,initp%can_temp) !---------------------------------------------------------------------------------------! - !------ Copy in the sea surface temperature and find associated values. ----------------! - initp%lake_temp = dble(leaf_g(ifm)%ground_temp(i,j,1)) - initp%lake_fliq = 1.d0 ! No sea ice for the time being... - !------ Find the mixing ratio, then convert to specific humidity. ----------------------! - initp%lake_ssh = rslif8(initp%can_prss,initp%lake_temp) - initp%lake_ssh = initp%lake_ssh / (initp%lake_ssh + 1.d0) - initp%lake_shv = initp%lake_ssh + + + !---------------------------------------------------------------------------------------! + ! Copy in the sea surface temperature, and find associated values such as the ! + ! lake surface specific humidity. ! + !---------------------------------------------------------------------------------------! + initp%lake_temp = dble(leaf_g(ifm)%ground_temp(i,j,1)) + initp%lake_fliq = 1.d0 ! No sea ice for the time being... + initp%lake_ssh = qslif8(initp%can_prss,initp%lake_temp) + initp%lake_shv = initp%lake_ssh !---------------------------------------------------------------------------------------! @@ -78,15 +89,17 @@ subroutine copy_lake_init(i,j,ifm,initp) initp%lake_rough = max(z0fac_water8 * ustar8 * ustar8,min_waterrough8) !---------------------------------------------------------------------------------------! - + + !----- Find the characteristic scales (a.k.a. stars). ----------------------------------! - call ed_stars8(lakemet%atm_theta,lakemet%atm_theiv,lakemet%atm_shv,lakemet%atm_co2 & - ,initp%can_theta ,initp%can_theiv ,initp%can_shv ,initp%can_co2 & + call ed_stars8(lakemet%atm_theta,lakemet%atm_enthalpy,lakemet%atm_shv,lakemet%atm_co2 & + ,initp%can_theta ,initp%can_enthalpy ,initp%can_shv ,initp%can_co2 & ,lakemet%geoht,0.d0,lakemet%atm_vels,initp%lake_rough & ,initp%ustar,initp%tstar,initp%estar,initp%qstar,initp%cstar & ,initp%zeta,initp%ribulk,initp%gglake) !---------------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------------! ! Apply the conductance factor (should be removed soon). Also, update the rough- ! ! ness so next time we use we have the most up to date value. ! @@ -98,14 +111,15 @@ subroutine copy_lake_init(i,j,ifm,initp) !---------------------------------------------------------------------------------------! ! Calculate the heat and mass storage capacity of the canopy. ! !---------------------------------------------------------------------------------------! - call can_whcap8(initp%can_rhos,initp%can_temp,initp%can_depth & - ,wcapcan,wcapcani,hcapcani,ccapcani) + call can_whccap8(initp%can_rhos,initp%can_depth & + ,wcapcan,hcapcan,ccapcan,wcapcani,hcapcani,ccapcani) !---------------------------------------------------------------------------------------! !----- Find the boundaries for the sanity check. ---------------------------------------! call lake_derived_thbounds(initp%can_rhos,initp%can_theta,initp%can_temp,initp%can_shv & - ,initp%can_rvap,initp%can_prss,initp%can_depth) + ,initp%can_prss,initp%can_depth) + !---------------------------------------------------------------------------------------! return end subroutine copy_lake_init @@ -125,43 +139,45 @@ subroutine lake_diagnostics(initp) use rk4_coms , only : rk4min_can_shv & ! intent(in) , rk4min_can_theta & ! intent(in) , rk4max_can_theta & ! intent(in) - , rk4min_can_lntheta & ! intent(in) - , rk4max_can_lntheta & ! intent(in) + , rk4min_can_enthalpy & ! intent(in) + , rk4max_can_enthalpy & ! intent(in) , rk4min_can_temp & ! intent(in) , rk4max_can_shv & ! intent(in) , rk4min_sfcw_temp & ! intent(in) , rk4max_sfcw_temp & ! intent(in) - , tiny_offset & ! intent(in) - , force_idealgas ! ! intent(in) + , tiny_offset ! ! intent(in) use lake_coms , only : lakesitetype & ! structure , lakemet & ! intent(in) , wcapcan & ! intent(in) + , hcapcan & ! intent(in) + , ccapcan & ! intent(in) , wcapcani & ! intent(in) , hcapcani & ! intent(in) , ccapcani ! ! intent(in) - use consts_coms , only : cp8 & ! intent(in) - , cpi8 & ! intent(in) - , p00i8 & ! intent(in) + use consts_coms , only : cpdry8 & ! intent(in) + , cph2o8 & ! intent(in) , rdry8 & ! intent(in) - , epim18 & ! intent(in) - , rocp8 ! ! intent(in) + , epim18 ! ! intent(in) use therm_lib8 , only : reducedpress8 & ! function , thetaeiv8 & ! function , idealdenssh8 & ! function , rehuil8 & ! function - , rslif8 & ! function - , thrhsh2temp8 ! ! function + , qslif8 & ! function + , extemp2theta8 & ! function + , thil2tqall8 & ! function + , hq2temp8 ! ! function use leaf_coms , only : min_waterrough8 & ! intent(in) , z0fac_water8 & ! intent(in) , can_depth_min ! ! intent(in) use canopy_air_coms , only : ustmin8 ! ! intent(in) use canopy_struct_dynamics, only : ed_stars8 & ! intent(in) - , can_whcap8 ! ! intent(in) + , can_whccap8 ! ! intent(in) implicit none !----- Arguments. ----------------------------------------------------------------------! type(lakesitetype), target :: initp !----- Local variables. ----------------------------------------------------------------! logical :: ok_shv + logical :: ok_enthalpy logical :: ok_theta logical :: ok_ground logical :: ok_flpoint @@ -174,87 +190,84 @@ subroutine lake_diagnostics(initp) !---------------------------------------------------------------------------------------! ! Sanity check. ! !---------------------------------------------------------------------------------------! - ok_flpoint = is_finite8(initp%can_shv) .and. is_finite8(initp%can_lntheta) .and. & - is_finite8(initp%can_prss) .and. is_finite8(initp%can_co2) .and. & + ok_flpoint = is_finite8(initp%can_shv) .and. is_finite8(initp%can_enthalpy) .and. & + is_finite8(initp%can_prss) .and. is_finite8(initp%can_co2) .and. & is_finite8(initp%lake_temp) if (.not. ok_flpoint) then write(unit=*,fmt='(a)' ) '-------------------------------------------------' write(unit=*,fmt='(a)' ) ' Something went wrong... ' write(unit=*,fmt='(a)' ) '-------------------------------------------------' write(unit=*,fmt='(a)' ) ' Meteorological forcing.' - write(unit=*,fmt='(a,1x,es12.5)') ' - Rhos :',lakemet%atm_rhos - write(unit=*,fmt='(a,1x,es12.5)') ' - Temp :',lakemet%atm_tmp - write(unit=*,fmt='(a,1x,es12.5)') ' - Theta :',lakemet%atm_theta - write(unit=*,fmt='(a,1x,es12.5)') ' - Theiv :',lakemet%atm_theiv - write(unit=*,fmt='(a,1x,es12.5)') ' - Lntheta :',lakemet%atm_lntheta - write(unit=*,fmt='(a,1x,es12.5)') ' - Shv :',lakemet%atm_shv - write(unit=*,fmt='(a,1x,es12.5)') ' - Rvap :',lakemet%atm_rvap - write(unit=*,fmt='(a,1x,es12.5)') ' - Rel. hum. :',lakemet%atm_rhv - write(unit=*,fmt='(a,1x,es12.5)') ' - CO2 :',lakemet%atm_co2 - write(unit=*,fmt='(a,1x,es12.5)') ' - Exner :',lakemet%atm_exner - write(unit=*,fmt='(a,1x,es12.5)') ' - Press :',lakemet%atm_prss - write(unit=*,fmt='(a,1x,es12.5)') ' - Vels :',lakemet%atm_vels - write(unit=*,fmt='(a,1x,es12.5)') ' - ucos :',lakemet%ucos - write(unit=*,fmt='(a,1x,es12.5)') ' - usin :',lakemet%usin - write(unit=*,fmt='(a,1x,es12.5)') ' - Geoht :',lakemet%geoht - write(unit=*,fmt='(a,1x,es12.5)') ' - d(SST)/dt :',lakemet%dsst_dt - write(unit=*,fmt='(a,1x,es12.5)') ' - Rshort :',lakemet%rshort - write(unit=*,fmt='(a,1x,es12.5)') ' - Rlong :',lakemet%rlong - write(unit=*,fmt='(a,1x,es12.5)') ' - Tanz :',lakemet%tanz - write(unit=*,fmt='(a,1x,es12.5)') ' - Lon :',lakemet%lon - write(unit=*,fmt='(a,1x,es12.5)') ' - Lat :',lakemet%lat + write(unit=*,fmt='(a,1x,es12.5)') ' - Rhos :',lakemet%atm_rhos + write(unit=*,fmt='(a,1x,es12.5)') ' - Temp :',lakemet%atm_tmp + write(unit=*,fmt='(a,1x,es12.5)') ' - Temp(Top of CAS) :',lakemet%atm_tmp + write(unit=*,fmt='(a,1x,es12.5)') ' - Theta :',lakemet%atm_theta + write(unit=*,fmt='(a,1x,es12.5)') ' - Specific enthalpy :',lakemet%atm_enthalpy + write(unit=*,fmt='(a,1x,es12.5)') ' - Shv :',lakemet%atm_shv + write(unit=*,fmt='(a,1x,es12.5)') ' - Rel. hum. :',lakemet%atm_rhv + write(unit=*,fmt='(a,1x,es12.5)') ' - CO2 :',lakemet%atm_co2 + write(unit=*,fmt='(a,1x,es12.5)') ' - Exner :',lakemet%atm_exner + write(unit=*,fmt='(a,1x,es12.5)') ' - Press :',lakemet%atm_prss + write(unit=*,fmt='(a,1x,es12.5)') ' - Vels :',lakemet%atm_vels + write(unit=*,fmt='(a,1x,es12.5)') ' - ucos :',lakemet%ucos + write(unit=*,fmt='(a,1x,es12.5)') ' - usin :',lakemet%usin + write(unit=*,fmt='(a,1x,es12.5)') ' - Geoht :',lakemet%geoht + write(unit=*,fmt='(a,1x,es12.5)') ' - d(SST)/dt :',lakemet%dsst_dt + write(unit=*,fmt='(a,1x,es12.5)') ' - Rshort :',lakemet%rshort + write(unit=*,fmt='(a,1x,es12.5)') ' - Rlong :',lakemet%rlong + write(unit=*,fmt='(a,1x,es12.5)') ' - Tanz :',lakemet%tanz + write(unit=*,fmt='(a,1x,es12.5)') ' - Lon :',lakemet%lon + write(unit=*,fmt='(a,1x,es12.5)') ' - Lat :',lakemet%lat write(unit=*,fmt='(a)' ) ' ' write(unit=*,fmt='(a)' ) '-------------------------------------------------' write(unit=*,fmt='(a)' ) ' Runge-Kutta structure.' write(unit=*,fmt='(a)' ) ' - Canopy air space.' - write(unit=*,fmt='(a,1x,es12.5)') ' * Rhos :',initp%can_rhos - write(unit=*,fmt='(a,1x,es12.5)') ' * Temp :',initp%can_temp - write(unit=*,fmt='(a,1x,es12.5)') ' * Theta :',initp%can_theta - write(unit=*,fmt='(a,1x,es12.5)') ' * Theiv :',initp%can_theiv - write(unit=*,fmt='(a,1x,es12.5)') ' * Lntheta :',initp%can_lntheta - write(unit=*,fmt='(a,1x,es12.5)') ' * Shv :',initp%can_shv - write(unit=*,fmt='(a,1x,es12.5)') ' * Rvap :',initp%can_rvap - write(unit=*,fmt='(a,1x,es12.5)') ' * Rel. hum. :',initp%can_rhv - write(unit=*,fmt='(a,1x,es12.5)') ' * CO2 :',initp%can_co2 - write(unit=*,fmt='(a,1x,es12.5)') ' * Exner :',initp%can_exner - write(unit=*,fmt='(a,1x,es12.5)') ' * Press :',initp%can_prss - write(unit=*,fmt='(a,1x,es12.5)') ' * Depth :',initp%can_depth + write(unit=*,fmt='(a,1x,es12.5)') ' * Rhos :',initp%can_rhos + write(unit=*,fmt='(a,1x,es12.5)') ' * Temp :',initp%can_temp + write(unit=*,fmt='(a,1x,es12.5)') ' * Theta :',initp%can_theta + write(unit=*,fmt='(a,1x,es12.5)') ' * Specific enthalpy:',initp%can_enthalpy + write(unit=*,fmt='(a,1x,es12.5)') ' * Shv :',initp%can_shv + write(unit=*,fmt='(a,1x,es12.5)') ' * Rel. hum. :',initp%can_rhv + write(unit=*,fmt='(a,1x,es12.5)') ' * CO2 :',initp%can_co2 + write(unit=*,fmt='(a,1x,es12.5)') ' * Exner :',initp%can_exner + write(unit=*,fmt='(a,1x,es12.5)') ' * Press :',initp%can_prss + write(unit=*,fmt='(a,1x,es12.5)') ' * Depth :',initp%can_depth write(unit=*,fmt='(a)' ) ' - Lake.' - write(unit=*,fmt='(a,1x,es12.5)') ' * Temp :',initp%lake_temp - write(unit=*,fmt='(a,1x,es12.5)') ' * Fliq :',initp%lake_fliq - write(unit=*,fmt='(a,1x,es12.5)') ' * Shv :',initp%lake_shv - write(unit=*,fmt='(a,1x,es12.5)') ' * Ssh :',initp%lake_ssh - write(unit=*,fmt='(a,1x,es12.5)') ' * Roughness :',initp%lake_rough + write(unit=*,fmt='(a,1x,es12.5)') ' * Temp :',initp%lake_temp + write(unit=*,fmt='(a,1x,es12.5)') ' * Fliq :',initp%lake_fliq + write(unit=*,fmt='(a,1x,es12.5)') ' * Shv :',initp%lake_shv + write(unit=*,fmt='(a,1x,es12.5)') ' * Ssh :',initp%lake_ssh + write(unit=*,fmt='(a,1x,es12.5)') ' * Roughness :',initp%lake_rough write(unit=*,fmt='(a)' ) ' - Stars.' - write(unit=*,fmt='(a,1x,es12.5)') ' * Ustar :',initp%ustar - write(unit=*,fmt='(a,1x,es12.5)') ' * Tstar :',initp%tstar - write(unit=*,fmt='(a,1x,es12.5)') ' * Estar :',initp%estar - write(unit=*,fmt='(a,1x,es12.5)') ' * Qstar :',initp%qstar - write(unit=*,fmt='(a,1x,es12.5)') ' * Cstar :',initp%cstar - write(unit=*,fmt='(a,1x,es12.5)') ' * Zeta :',initp%zeta - write(unit=*,fmt='(a,1x,es12.5)') ' * Ribulk :',initp%ribulk - write(unit=*,fmt='(a,1x,es12.5)') ' * GGlake :',initp%gglake + write(unit=*,fmt='(a,1x,es12.5)') ' * Ustar :',initp%ustar + write(unit=*,fmt='(a,1x,es12.5)') ' * Tstar :',initp%tstar + write(unit=*,fmt='(a,1x,es12.5)') ' * Estar :',initp%estar + write(unit=*,fmt='(a,1x,es12.5)') ' * Qstar :',initp%qstar + write(unit=*,fmt='(a,1x,es12.5)') ' * Cstar :',initp%cstar + write(unit=*,fmt='(a,1x,es12.5)') ' * Zeta :',initp%zeta + write(unit=*,fmt='(a,1x,es12.5)') ' * Ribulk :',initp%ribulk + write(unit=*,fmt='(a,1x,es12.5)') ' * GGlake :',initp%gglake write(unit=*,fmt='(a)' ) ' - Partially integrated fluxes.' - write(unit=*,fmt='(a,1x,es12.5)') ' * Vapour_gc :',initp%avg_vapor_gc - write(unit=*,fmt='(a,1x,es12.5)') ' * Vapour_ac :',initp%avg_vapor_ac - write(unit=*,fmt='(a,1x,es12.5)') ' * Sensible_gc :',initp%avg_sensible_gc - write(unit=*,fmt='(a,1x,es12.5)') ' * Sensible_ac :',initp%avg_sensible_ac - write(unit=*,fmt='(a,1x,es12.5)') ' * Carbon_gc :',initp%avg_carbon_gc - write(unit=*,fmt='(a,1x,es12.5)') ' * Carbon_ac :',initp%avg_carbon_ac - write(unit=*,fmt='(a,1x,es12.5)') ' * Carbon_st :',initp%avg_carbon_st - write(unit=*,fmt='(a,1x,es12.5)') ' * Sflux_u :',initp%avg_sflux_u - write(unit=*,fmt='(a,1x,es12.5)') ' * Sflux_v :',initp%avg_sflux_u - write(unit=*,fmt='(a,1x,es12.5)') ' * Sflux_w :',initp%avg_sflux_w - write(unit=*,fmt='(a,1x,es12.5)') ' * Sflux_t :',initp%avg_sflux_t - write(unit=*,fmt='(a,1x,es12.5)') ' * Sflux_r :',initp%avg_sflux_r - write(unit=*,fmt='(a,1x,es12.5)') ' * Sflux_c :',initp%avg_sflux_c - write(unit=*,fmt='(a,1x,es12.5)') ' * Albedt :',initp%avg_albedt - write(unit=*,fmt='(a,1x,es12.5)') ' * Rlongup :',initp%avg_rlongup - write(unit=*,fmt='(a,1x,es12.5)') ' * Rshort_gnd :',initp%avg_rshort_gnd - write(unit=*,fmt='(a,1x,es12.5)') ' * Ustar :',initp%avg_ustar - write(unit=*,fmt='(a,1x,es12.5)') ' * Tstar :',initp%avg_tstar - write(unit=*,fmt='(a,1x,es12.5)') ' * Qstar :',initp%avg_qstar - write(unit=*,fmt='(a,1x,es12.5)') ' * Cstar :',initp%avg_cstar + write(unit=*,fmt='(a,1x,es12.5)') ' * Vapour_gc :',initp%avg_vapor_gc + write(unit=*,fmt='(a,1x,es12.5)') ' * Vapour_ac :',initp%avg_vapor_ac + write(unit=*,fmt='(a,1x,es12.5)') ' * Sensible_gc :',initp%avg_sensible_gc + write(unit=*,fmt='(a,1x,es12.5)') ' * Sensible_ac :',initp%avg_sensible_ac + write(unit=*,fmt='(a,1x,es12.5)') ' * Carbon_gc :',initp%avg_carbon_gc + write(unit=*,fmt='(a,1x,es12.5)') ' * Carbon_ac :',initp%avg_carbon_ac + write(unit=*,fmt='(a,1x,es12.5)') ' * Carbon_st :',initp%avg_carbon_st + write(unit=*,fmt='(a,1x,es12.5)') ' * Sflux_u :',initp%avg_sflux_u + write(unit=*,fmt='(a,1x,es12.5)') ' * Sflux_v :',initp%avg_sflux_u + write(unit=*,fmt='(a,1x,es12.5)') ' * Sflux_w :',initp%avg_sflux_w + write(unit=*,fmt='(a,1x,es12.5)') ' * Sflux_t :',initp%avg_sflux_t + write(unit=*,fmt='(a,1x,es12.5)') ' * Sflux_r :',initp%avg_sflux_r + write(unit=*,fmt='(a,1x,es12.5)') ' * Sflux_c :',initp%avg_sflux_c + write(unit=*,fmt='(a,1x,es12.5)') ' * Albedt :',initp%avg_albedt + write(unit=*,fmt='(a,1x,es12.5)') ' * Rlongup :',initp%avg_rlongup + write(unit=*,fmt='(a,1x,es12.5)') ' * Rshort_gnd :',initp%avg_rshort_gnd + write(unit=*,fmt='(a,1x,es12.5)') ' * Ustar :',initp%avg_ustar + write(unit=*,fmt='(a,1x,es12.5)') ' * Tstar :',initp%avg_tstar + write(unit=*,fmt='(a,1x,es12.5)') ' * Qstar :',initp%avg_qstar + write(unit=*,fmt='(a,1x,es12.5)') ' * Cstar :',initp%avg_cstar write(unit=*,fmt='(a)' ) ' ' write(unit=*,fmt='(a)' ) '-------------------------------------------------' call abort_run('Non-resolvable values','lake_diagnostics','edcp_lake_misc.f90') @@ -262,12 +275,12 @@ subroutine lake_diagnostics(initp) !----- Then we define some logicals to make the code cleaner. --------------------------! - ok_shv = initp%can_shv >= rk4min_can_shv .and. & - initp%can_shv <= rk4max_can_shv - ok_theta = initp%can_lntheta >= rk4min_can_lntheta .and. & - initp%can_lntheta <= rk4max_can_lntheta - ok_ground = initp%lake_temp >= rk4min_sfcw_temp .and. & - initp%lake_temp <= rk4max_sfcw_temp + ok_shv = initp%can_shv >= rk4min_can_shv .and. & + initp%can_shv <= rk4max_can_shv + ok_enthalpy = initp%can_enthalpy >= rk4min_can_enthalpy .and. & + initp%can_enthalpy <= rk4max_can_enthalpy + ok_ground = initp%lake_temp >= rk4min_sfcw_temp .and. & + initp%lake_temp <= rk4max_sfcw_temp !---------------------------------------------------------------------------------------! @@ -280,77 +293,77 @@ subroutine lake_diagnostics(initp) ! log) should eventually become the prognostic variable for canopy air space entropy ! ! when we add condensed/frozen water in the canopy air space. ! !---------------------------------------------------------------------------------------! - if (ok_shv .and. ok_theta) then - - !----- First, we update the canopy air potential temperature. -----------------------! - initp%can_theta = exp(initp%can_lntheta) + if (ok_shv .and. ok_enthalpy) then - !----- Update the canop air - initp%can_rvap = initp%can_shv / (1.d0 - initp%can_shv) + !----- Update the canopy air space heat capacity at constant pressure. --------------! + initp%can_cp = (1.d0 - initp%can_shv) * cpdry8 + initp%can_shv * cph2o8 !------------------------------------------------------------------------------------! - ! Here we find the temperature in different ways depending on whether we are ! - ! keeping pressure constant during one full time step or not. If we are forcing ! - ! ideal gas to be always respected, then we don't know the pressure until we have ! - ! the temperature, so we compute the temperature based on potential temperature, ! - ! density, and specific humidity, then update pressure. Otherwise, we compute the ! - ! temperature using the known pressure, even though this causes the ideal gas law to ! - ! not be always satisfied. ! + + !----- Find the canopy air temperature. ---------------------------------------------! + initp%can_temp = hq2temp8(initp%can_enthalpy,initp%can_shv,.true.) !------------------------------------------------------------------------------------! - if (force_idealgas) then - initp%can_temp = thrhsh2temp8(initp%can_theta,initp%can_rhos,initp%can_shv) - initp%can_prss = initp%can_rhos * rdry8 * initp%can_temp & - * (1.d0 + epim18 * initp%can_shv) - initp%can_exner = cp8 * (initp%can_prss * p00i8) ** rocp8 - else - initp%can_temp = cpi8 * initp%can_theta * initp%can_exner - end if + + !----- Find the new potential temperature. ------------------------------------------! + initp%can_theta = extemp2theta8(initp%can_exner,initp%can_temp) !------------------------------------------------------------------------------------! - !----- Find derived properties. -----------------------------------------------------! - initp%can_rhv = rehuil8(initp%can_prss,initp%can_temp,initp%can_rvap) - initp%can_ssh = rslif8(initp%can_prss,initp%can_temp) - initp%can_ssh = initp%can_ssh / (initp%can_ssh + 1.d0) - initp%can_theiv = thetaeiv8(initp%can_theta,initp%can_prss,initp%can_temp & - ,initp%can_rvap,initp%can_rvap) + !----- Check whether the potential temperature makes sense or not. ------------------! + ok_theta = initp%can_theta >= rk4min_can_theta .and. & + initp%can_theta <= rk4max_can_theta !------------------------------------------------------------------------------------! - !----- Find the characteristic scales (a.k.a. stars). -------------------------------! - call ed_stars8(lakemet%atm_theta,lakemet%atm_theiv,lakemet%atm_shv,lakemet%atm_co2 & - ,initp%can_theta ,initp%can_theiv ,initp%can_shv ,initp%can_co2 & - ,lakemet%geoht,0.d0,lakemet%atm_vels,initp%lake_rough & - ,initp%ustar,initp%tstar,initp%estar,initp%qstar,initp%cstar & - ,initp%zeta,initp%ribulk,initp%gglake) !------------------------------------------------------------------------------------! + ! Compute the other canopy air parameters only if the potential temperature ! + ! makes sense. Sometimes enthalpy makes sense even though the temperature is bad, ! + ! because can_shv is way off in the opposite direction of temperature. ! + !------------------------------------------------------------------------------------! + if (ok_theta) then + !---------------------------------------------------------------------------------! + ! Find the derived humidity variables. ! + !---------------------------------------------------------------------------------! + initp%can_rhv = rehuil8(initp%can_prss,initp%can_temp,initp%can_shv,.true.) + initp%can_ssh = qslif8(initp%can_prss,initp%can_temp) + !---------------------------------------------------------------------------------! - !------------------------------------------------------------------------------------! - ! Apply the conductance factor (should be removed soon). Also, update the ! - ! roughness so next time we use we have the most up to date value. ! - !------------------------------------------------------------------------------------! - initp%lake_rough = max(z0fac_water8 * initp%ustar * initp%ustar,min_waterrough8) - !------------------------------------------------------------------------------------! + !----- Find the characteristic scales (a.k.a. stars). ----------------------------! + call ed_stars8(lakemet%atm_theta,lakemet%atm_enthalpy,lakemet%atm_shv & + ,lakemet%atm_co2,initp%can_theta,initp%can_enthalpy,initp%can_shv & + ,initp%can_co2,lakemet%geoht,0.d0,lakemet%atm_vels,initp%lake_rough & + ,initp%ustar,initp%tstar,initp%estar,initp%qstar,initp%cstar & + ,initp%zeta,initp%ribulk,initp%gglake) + !---------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------! + ! Apply the conductance factor (should be removed soon). Also, update the ! + ! roughness so next time we use we have the most up to date value. ! + !---------------------------------------------------------------------------------! + initp%lake_rough = max(z0fac_water8 * initp%ustar * initp%ustar,min_waterrough8) + !---------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------! + ! Calculate the heat and mass storage capacity of the canopy. ! + !---------------------------------------------------------------------------------! + call can_whccap8(initp%can_rhos,initp%can_depth & + ,wcapcan,hcapcan,ccapcan,wcapcani,hcapcani,ccapcani) + !---------------------------------------------------------------------------------! + end if !------------------------------------------------------------------------------------! - ! Calculate the heat and mass storage capacity of the canopy. ! + else !------------------------------------------------------------------------------------! - call can_whcap8(initp%can_rhos,initp%can_temp,initp%can_depth & - ,wcapcan,wcapcani,hcapcani,ccapcani) + ! Set potential temperature flag to false (not really useful). ! + !------------------------------------------------------------------------------------! + ok_theta = .false. !------------------------------------------------------------------------------------! - - elseif (initp%can_lntheta >= rk4max_can_lntheta) then - !----- CAS is too hot, put a non-sense temperature so the sanity check fails. -------! - initp%can_theta = rk4max_can_theta + 1.d0 - - elseif (initp%can_lntheta <= rk4min_can_lntheta) then - !----- CAS is too cold, put a non-sense temperature so the sanity check fails. ------! - initp%can_theta = rk4min_can_theta - 1.d0 end if !---------------------------------------------------------------------------------------! @@ -359,8 +372,7 @@ subroutine lake_diagnostics(initp) !------ Find the mixing ratio, then convert to specific humidity. ----------------------! if (ok_ground) then - initp%lake_ssh = rslif8(initp%can_prss,initp%lake_temp) - initp%lake_ssh = initp%lake_ssh / (1.d0 + initp%lake_ssh) + initp%lake_ssh = qslif8(initp%can_prss,initp%lake_temp) initp%lake_shv = initp%lake_ssh end if !---------------------------------------------------------------------------------------! @@ -390,22 +402,24 @@ subroutine lake_derivs(initp,dinitp) , albt_slope & ! intent(in) , albt_min & ! intent(in) , albt_max ! ! intent(in) - use consts_coms , only : cp8 & ! intent(in) - , mmdryi8 & ! intent(in) + use consts_coms , only : mmdryi8 & ! intent(in) , stefan8 ! ! intent(in) + use therm_lib8 , only : tq2enthalpy8 ! ! intent(in) use canopy_struct_dynamics, only : vertical_vel_flux8 ! ! function implicit none !----- Arguments. ----------------------------------------------------------------------! - type(lakesitetype) :: initp ! ! Current guess - type(lakesitetype) :: dinitp ! ! Current derivative + type(lakesitetype) :: initp ! Current guess + type(lakesitetype) :: dinitp ! Current derivative !----- Local variables. ----------------------------------------------------------------! - real(kind=8) :: wflxac - real(kind=8) :: hflxac - real(kind=8) :: cflxac - real(kind=8) :: wflxgc - real(kind=8) :: hflxgc - real(kind=8) :: cflxgc - real(kind=8) :: rho_ustar + real(kind=8) :: wflxac ! Water flux (Atmosphere -> CAS) [ kg/m²/s] + real(kind=8) :: hflxac ! Sensible heat flux (Atmosphere -> CAS) [ W/m²] + real(kind=8) :: eflxac ! Enthalpy flux (Atmosphere -> CAS) [ W/m²] + real(kind=8) :: cflxac ! CO2 flux (Atmosphere -> CAS) [ µmol/m²/s] + real(kind=8) :: wflxgc ! Water flux (Ground -> CAS) [ kg/m²/s] + real(kind=8) :: qwflxgc ! Latent heat flux (Ground -> CAS) [ W/m²] + real(kind=8) :: hflxgc ! Sensible heat flux (Ground -> CAS) [ W/m²] + real(kind=8) :: cflxgc ! CO2 flux (Ground -> CAS) [ µmol/m²/s] + real(kind=8) :: rho_ustar ! rho * ustar [ kg/m²/s] !---------------------------------------------------------------------------------------! @@ -414,23 +428,26 @@ subroutine lake_derivs(initp,dinitp) rho_ustar = initp%can_rhos * initp%ustar wflxac = rho_ustar * initp%qstar hflxac = rho_ustar * initp%tstar * initp%can_exner + eflxac = rho_ustar * initp%estar cflxac = rho_ustar * initp%cstar * mmdryi8 !---------------------------------------------------------------------------------------! !----- Find the ground => canopy air space fluxes. -------------------------------------! - wflxgc = initp%can_rhos * initp%gglake * (initp%lake_shv - initp%can_shv ) - hflxgc = cp8 * initp%can_rhos * initp%gglake * (initp%lake_temp - initp%can_temp) + wflxgc = initp%can_rhos * initp%gglake * (initp%lake_shv - initp%can_shv ) + qwflxgc = wflxgc * tq2enthalpy8(initp%lake_temp,1.d0,.true.) + hflxgc = initp%can_rhos * initp%gglake & + * initp%can_cp * (initp%lake_temp - initp%can_temp) cflxgc = 0.d0 ! We should add a simple ocean flux model at some point in the future. !---------------------------------------------------------------------------------------! !----- Find the derivatives of the canopy air space. -----------------------------------! - dinitp%can_shv = (wflxgc + wflxac) * wcapcani - dinitp%can_lntheta = (hflxgc + hflxac) * hcapcani - dinitp%can_co2 = (cflxgc + cflxac) * ccapcani + dinitp%can_shv = ( wflxgc + wflxac ) * wcapcani + dinitp%can_enthalpy = ( hflxgc + qwflxgc + eflxac ) * hcapcani + dinitp%can_co2 = ( cflxgc + cflxac ) * ccapcani !---------------------------------------------------------------------------------------! @@ -500,17 +517,14 @@ end subroutine lake_derivs ! This subroutine finds the derived properties for the Runge-Kutta/Euler tests on ! ! water regions. ! !------------------------------------------------------------------------------------------! -subroutine lake_derived_thbounds(can_rhos,can_theta,can_temp,can_shv,can_rvap,can_prss & - ,can_depth) - use consts_coms , only : p008 & ! intent(in) - , rocp8 & ! intent(in) - , cp8 & ! intent(in) - , rdry8 & ! intent(in) +subroutine lake_derived_thbounds(can_rhos,can_theta,can_temp,can_shv,can_prss,can_depth) + use consts_coms , only : rdry8 & ! intent(in) , epim18 & ! intent(in) , ep8 & ! intent(in) , mmdryi8 ! ! intent(in) - use therm_lib8 , only : thetaeiv8 & ! function - , thetaeivs8 & ! function + use therm_lib8 , only : press2exner8 & ! function + , extemp2theta8 & ! function + , tq2enthalpy8 & ! function , idealdenssh8 & ! function , reducedpress8 & ! function , eslif8 & ! function @@ -520,29 +534,26 @@ subroutine lake_derived_thbounds(can_rhos,can_theta,can_temp,can_shv,can_rvap,ca , rk4max_can_prss & ! intent(in) , rk4min_can_theta & ! intent(in) , rk4max_can_theta & ! intent(in) - , rk4min_can_theiv & ! intent(in) - , rk4max_can_theiv & ! intent(in) , rk4min_can_temp & ! intent(in) , rk4max_can_temp & ! intent(in) , rk4min_can_shv & ! intent(in) , rk4max_can_shv & ! intent(in) - , rk4max_can_rvap & ! intent(in) - , rk4min_can_lntheta & ! intent(in) - , rk4max_can_lntheta ! ! intent(in) + , rk4min_can_enthalpy & ! intent(in) + , rk4max_can_enthalpy ! ! intent(in) implicit none - !----- Arguments. -------------------------------------------------------------------! - real(kind=8) , intent(in) :: can_rhos - real(kind=8) , intent(in) :: can_theta - real(kind=8) , intent(in) :: can_temp - real(kind=8) , intent(in) :: can_shv - real(kind=8) , intent(in) :: can_rvap - real(kind=8) , intent(in) :: can_prss - real(kind=8) , intent(in) :: can_depth + !----- Arguments. ----------------------------------------------------------------------! + real(kind=8), intent(in) :: can_rhos + real(kind=8), intent(in) :: can_theta + real(kind=8), intent(in) :: can_temp + real(kind=8), intent(in) :: can_shv + real(kind=8), intent(in) :: can_prss + real(kind=8), intent(in) :: can_depth !----- Local variables. ----------------------------------------------------------------! - real(kind=8) :: can_prss_try - real(kind=8) :: can_theta_try - real(kind=8) :: can_theiv_try - integer :: k + real(kind=8) :: can_prss_try + real(kind=8) :: can_theta_try + real(kind=8) :: can_exner_try + real(kind=8) :: can_enthalpy_try + integer :: k !---------------------------------------------------------------------------------------! @@ -587,46 +598,51 @@ subroutine lake_derived_thbounds(can_rhos,can_theta,can_temp,can_shv,can_rvap,ca rk4min_can_theta = huge(1.d0) rk4max_can_theta = -huge(1.d0) !----- 2. Minimum temperature. ---------------------------------------------------------! - can_theta_try = rk4min_can_temp * (p008 / can_prss) ** rocp8 + can_exner_try = press2exner8(can_prss) + can_theta_try = extemp2theta8(can_exner_try,rk4min_can_temp) rk4min_can_theta = min(rk4min_can_theta,can_theta_try) rk4max_can_theta = max(rk4max_can_theta,can_theta_try) !----- 3. Maximum temperature. ---------------------------------------------------------! - can_theta_try = rk4max_can_temp * (p008 / can_prss) ** rocp8 + can_exner_try = press2exner8(can_prss) + can_theta_try = extemp2theta8(can_exner_try,rk4max_can_temp) rk4min_can_theta = min(rk4min_can_theta,can_theta_try) rk4max_can_theta = max(rk4max_can_theta,can_theta_try) !----- 4. Minimum pressure. ------------------------------------------------------------! - can_theta_try = can_temp * (p008 / rk4min_can_prss) ** rocp8 + can_exner_try = press2exner8(rk4min_can_prss) + can_theta_try = extemp2theta8(can_exner_try,can_temp) rk4min_can_theta = min(rk4min_can_theta,can_theta_try) rk4max_can_theta = max(rk4max_can_theta,can_theta_try) !----- 5. Maximum pressure. ------------------------------------------------------------! - can_theta_try = can_temp * (p008 / rk4max_can_prss) ** rocp8 + can_exner_try = press2exner8(rk4max_can_prss) + can_theta_try = extemp2theta8(can_exner_try,can_temp) rk4min_can_theta = min(rk4min_can_theta,can_theta_try) rk4max_can_theta = max(rk4max_can_theta,can_theta_try) - !----- 6. Find the logarithms. ---------------------------------------------------------! - rk4min_can_lntheta = log(rk4min_can_theta) - rk4max_can_lntheta = log(rk4max_can_theta) !---------------------------------------------------------------------------------------! !---------------------------------------------------------------------------------------! - ! Minimum and maximum ice-vapour equivalent potential temperature. ! + ! Minimum and maximum enthalpy. ! !---------------------------------------------------------------------------------------! !----- 1. Initial value, the most extreme one. -----------------------------------------! - rk4min_can_theiv = rk4min_can_theta - rk4max_can_theiv = -huge(1.d0) - !----- 2. Maximum temperature. ---------------------------------------------------------! - can_theta_try = rk4max_can_temp * (p008 / can_prss) ** rocp8 - can_theiv_try = thetaeivs8(can_theta_try,rk4max_can_temp,can_rvap,0.d0,0.d0) - rk4max_can_theiv = max(rk4max_can_theiv,can_theiv_try) - !----- 3. Minimum pressure. ------------------------------------------------------------! - can_theta_try = can_temp * (p008 / rk4min_can_prss) ** rocp8 - can_theiv_try = thetaeivs8(can_theta_try,can_temp,can_rvap,0.d0,0.d0) - rk4max_can_theiv = max(rk4max_can_theiv,can_theiv_try) - !----- 4. Maximum vapour mixing ratio. -------------------------------------------------! - can_theta_try = can_temp * (p008 / can_prss) ** rocp8 - can_theiv_try = thetaeivs8(can_theta_try,can_temp,rk4max_can_rvap,0.d0,0.d0) - rk4max_can_theiv = max(rk4max_can_theiv,can_theiv_try) + rk4min_can_enthalpy = huge(1.d0) + rk4max_can_enthalpy = - huge(1.d0) + !----- 2. Minimum temperature. ---------------------------------------------------------! + can_enthalpy_try = tq2enthalpy8(rk4min_can_temp,can_shv,.true.) + rk4min_can_enthalpy = min(rk4min_can_enthalpy,can_enthalpy_try) + rk4max_can_enthalpy = max(rk4max_can_enthalpy,can_enthalpy_try) + !----- 3. Maximum temperature. ---------------------------------------------------------! + can_enthalpy_try = tq2enthalpy8(rk4max_can_temp,can_shv,.true.) + rk4min_can_enthalpy = min(rk4min_can_enthalpy,can_enthalpy_try) + rk4max_can_enthalpy = max(rk4max_can_enthalpy,can_enthalpy_try) + !----- 4. Minimum specific humidity. ---------------------------------------------------! + can_enthalpy_try = tq2enthalpy8(can_temp,rk4min_can_shv,.true.) + rk4min_can_enthalpy = min(rk4min_can_enthalpy,can_enthalpy_try) + rk4max_can_enthalpy = max(rk4max_can_enthalpy,can_enthalpy_try) + !----- 5. Maximum specific humidity. ---------------------------------------------------! + can_enthalpy_try = tq2enthalpy8(can_temp,rk4max_can_shv,.true.) + rk4min_can_enthalpy = min(rk4min_can_enthalpy,can_enthalpy_try) + rk4max_can_enthalpy = max(rk4max_can_enthalpy,can_enthalpy_try) !---------------------------------------------------------------------------------------! return @@ -647,8 +663,6 @@ end subroutine lake_derived_thbounds !------------------------------------------------------------------------------------------! subroutine lake_sanity_check(y,reject_step,dydx,h,print_problems) use rk4_coms , only : rk4eps & ! intent(in) - , rk4min_can_theiv & ! intent(in) - , rk4max_can_theiv & ! intent(in) , rk4min_can_theta & ! intent(in) , rk4max_can_theta & ! intent(in) , rk4max_can_shv & ! intent(in) @@ -657,8 +671,8 @@ subroutine lake_sanity_check(y,reject_step,dydx,h,print_problems) , rk4max_can_rhv & ! intent(in) , rk4min_can_temp & ! intent(in) , rk4max_can_temp & ! intent(in) - , rk4min_can_theiv & ! intent(in) - , rk4max_can_theiv & ! intent(in) + , rk4min_can_enthalpy & ! intent(in) + , rk4max_can_enthalpy & ! intent(in) , rk4min_can_prss & ! intent(in) , rk4max_can_prss & ! intent(in) , rk4min_can_co2 & ! intent(in) @@ -685,15 +699,16 @@ subroutine lake_sanity_check(y,reject_step,dydx,h,print_problems) !---------------------------------------------------------------------------------------! - ! Check whether the canopy air equivalent potential temperature is off. ! + ! Check whether the canopy air specific enthalpy is off. ! !---------------------------------------------------------------------------------------! - if (y%can_theiv > rk4max_can_theiv .or. y%can_theiv < rk4min_can_theiv ) then + if (y%can_enthalpy > rk4max_can_enthalpy .or. y%can_enthalpy < rk4min_can_enthalpy ) & + then reject_step = .true. if (print_problems) then write(unit=*,fmt='(a)') '===========================================' - write(unit=*,fmt='(a)') ' + Canopy air theta_Eiv is off-track...' + write(unit=*,fmt='(a)') ' + Canopy air enthalpy is off-track...' write(unit=*,fmt='(a)') '-------------------------------------------' - write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THEIV: ',y%can_theiv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_ENTHALPY: ',y%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THETA: ',y%can_theta write(unit=*,fmt='(a,1x,es12.4)') ' CAN_SHV: ',y%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHV: ',y%can_rhv @@ -704,7 +719,7 @@ subroutine lake_sanity_check(y,reject_step,dydx,h,print_problems) write(unit=*,fmt='(a,1x,es12.4)') ' CAN_PRSS: ',y%can_prss write(unit=*,fmt='(a,1x,es12.4)') ' LAKE_TEMP: ',y%lake_temp write(unit=*,fmt='(a,1x,es12.4)') ' LAKE_SHV: ',y%lake_shv - write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_LNTHETA )/Dt:',dydx%can_lntheta + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_ENTHALPY)/Dt:',dydx%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_SHV )/Dt:',dydx%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_CO2 )/Dt:',dydx%can_co2 write(unit=*,fmt='(a,1x,es12.4)') ' D(LAKE_TEMP )/Dt:',dydx%lake_temp @@ -727,7 +742,7 @@ subroutine lake_sanity_check(y,reject_step,dydx,h,print_problems) write(unit=*,fmt='(a)') '===========================================' write(unit=*,fmt='(a)') ' + Canopy air pot. temp. is off-track...' write(unit=*,fmt='(a)') '-------------------------------------------' - write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THEIV: ',y%can_theiv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_ENTHALPY: ',y%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THETA: ',y%can_theta write(unit=*,fmt='(a,1x,es12.4)') ' CAN_SHV: ',y%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHV: ',y%can_rhv @@ -738,7 +753,7 @@ subroutine lake_sanity_check(y,reject_step,dydx,h,print_problems) write(unit=*,fmt='(a,1x,es12.4)') ' CAN_PRSS: ',y%can_prss write(unit=*,fmt='(a,1x,es12.4)') ' LAKE_TEMP: ',y%lake_temp write(unit=*,fmt='(a,1x,es12.4)') ' LAKE_SHV: ',y%lake_shv - write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_LNTHETA )/Dt:',dydx%can_lntheta + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_ENTHALPY)/Dt:',dydx%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_SHV )/Dt:',dydx%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_CO2 )/Dt:',dydx%can_co2 write(unit=*,fmt='(a,1x,es12.4)') ' D(LAKE_TEMP )/Dt:',dydx%lake_temp @@ -761,7 +776,7 @@ subroutine lake_sanity_check(y,reject_step,dydx,h,print_problems) write(unit=*,fmt='(a)') '===========================================' write(unit=*,fmt='(a)') ' + Canopy air sp. humidity is off-track...' write(unit=*,fmt='(a)') '-------------------------------------------' - write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THEIV: ',y%can_theiv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_ENTHALPY: ',y%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THETA: ',y%can_theta write(unit=*,fmt='(a,1x,es12.4)') ' CAN_SHV: ',y%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHV: ',y%can_rhv @@ -772,7 +787,7 @@ subroutine lake_sanity_check(y,reject_step,dydx,h,print_problems) write(unit=*,fmt='(a,1x,es12.4)') ' CAN_PRSS: ',y%can_prss write(unit=*,fmt='(a,1x,es12.4)') ' LAKE_TEMP: ',y%lake_temp write(unit=*,fmt='(a,1x,es12.4)') ' LAKE_SHV: ',y%lake_shv - write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_LNTHETA )/Dt:',dydx%can_lntheta + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_ENTHALPY)/Dt:',dydx%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_SHV )/Dt:',dydx%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_CO2 )/Dt:',dydx%can_co2 write(unit=*,fmt='(a,1x,es12.4)') ' D(LAKE_TEMP )/Dt:',dydx%lake_temp @@ -795,7 +810,7 @@ subroutine lake_sanity_check(y,reject_step,dydx,h,print_problems) write(unit=*,fmt='(a)') '===========================================' write(unit=*,fmt='(a)') ' + Canopy air temperature is off-track...' write(unit=*,fmt='(a)') '-------------------------------------------' - write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THEIV: ',y%can_theiv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_ENTHALPY: ',y%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THETA: ',y%can_theta write(unit=*,fmt='(a,1x,es12.4)') ' CAN_SHV: ',y%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHV: ',y%can_rhv @@ -806,7 +821,7 @@ subroutine lake_sanity_check(y,reject_step,dydx,h,print_problems) write(unit=*,fmt='(a,1x,es12.4)') ' CAN_PRSS: ',y%can_prss write(unit=*,fmt='(a,1x,es12.4)') ' LAKE_TEMP: ',y%lake_temp write(unit=*,fmt='(a,1x,es12.4)') ' LAKE_SHV: ',y%lake_shv - write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_LNTHETA )/Dt:',dydx%can_lntheta + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_ENTHALPY)/Dt:',dydx%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_SHV )/Dt:',dydx%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_CO2 )/Dt:',dydx%can_co2 write(unit=*,fmt='(a,1x,es12.4)') ' D(LAKE_TEMP )/Dt:',dydx%lake_temp @@ -829,7 +844,7 @@ subroutine lake_sanity_check(y,reject_step,dydx,h,print_problems) write(unit=*,fmt='(a)') '===========================================' write(unit=*,fmt='(a)') ' + Canopy air pressure is off-track...' write(unit=*,fmt='(a)') '-------------------------------------------' - write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THEIV: ',y%can_theiv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_ENTHALPY: ',y%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THETA: ',y%can_theta write(unit=*,fmt='(a,1x,es12.4)') ' CAN_SHV: ',y%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHV: ',y%can_rhv @@ -840,7 +855,7 @@ subroutine lake_sanity_check(y,reject_step,dydx,h,print_problems) write(unit=*,fmt='(a,1x,es12.4)') ' CAN_PRSS: ',y%can_prss write(unit=*,fmt='(a,1x,es12.4)') ' LAKE_TEMP: ',y%lake_temp write(unit=*,fmt='(a,1x,es12.4)') ' LAKE_SHV: ',y%lake_shv - write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_LNTHETA )/Dt:',dydx%can_lntheta + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_ENTHALPY)/Dt:',dydx%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_SHV )/Dt:',dydx%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_CO2 )/Dt:',dydx%can_co2 write(unit=*,fmt='(a,1x,es12.4)') ' D(LAKE_TEMP )/Dt:',dydx%lake_temp @@ -864,7 +879,7 @@ subroutine lake_sanity_check(y,reject_step,dydx,h,print_problems) write(unit=*,fmt='(a)') '===========================================' write(unit=*,fmt='(a)') ' + Canopy air CO2 is off-track...' write(unit=*,fmt='(a)') '-------------------------------------------' - write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THEIV: ',y%can_theiv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_ENTHALPY: ',y%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THETA: ',y%can_theta write(unit=*,fmt='(a,1x,es12.4)') ' CAN_SHV: ',y%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHV: ',y%can_rhv @@ -875,7 +890,7 @@ subroutine lake_sanity_check(y,reject_step,dydx,h,print_problems) write(unit=*,fmt='(a,1x,es12.4)') ' CAN_PRSS: ',y%can_prss write(unit=*,fmt='(a,1x,es12.4)') ' LAKE_TEMP: ',y%lake_temp write(unit=*,fmt='(a,1x,es12.4)') ' LAKE_SHV: ',y%lake_shv - write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_LNTHETA )/Dt:',dydx%can_lntheta + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_ENTHALPY)/Dt:',dydx%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_SHV )/Dt:',dydx%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_CO2 )/Dt:',dydx%can_co2 write(unit=*,fmt='(a,1x,es12.4)') ' D(LAKE_TEMP )/Dt:',dydx%lake_temp @@ -899,7 +914,7 @@ subroutine lake_sanity_check(y,reject_step,dydx,h,print_problems) write(unit=*,fmt='(a)') '===========================================' write(unit=*,fmt='(a)') ' + Lake(SST) temperature is off-track...' write(unit=*,fmt='(a)') '-------------------------------------------' - write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THEIV: ',y%can_theiv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_ENTHALPY: ',y%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THETA: ',y%can_theta write(unit=*,fmt='(a,1x,es12.4)') ' CAN_SHV: ',y%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHV: ',y%can_rhv @@ -910,7 +925,7 @@ subroutine lake_sanity_check(y,reject_step,dydx,h,print_problems) write(unit=*,fmt='(a,1x,es12.4)') ' CAN_PRSS: ',y%can_prss write(unit=*,fmt='(a,1x,es12.4)') ' LAKE_TEMP: ',y%lake_temp write(unit=*,fmt='(a,1x,es12.4)') ' LAKE_SHV: ',y%lake_shv - write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_LNTHETA )/Dt:',dydx%can_lntheta + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_ENTHALPY)/Dt:',dydx%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_SHV )/Dt:',dydx%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_CO2 )/Dt:',dydx%can_co2 write(unit=*,fmt='(a,1x,es12.4)') ' D(LAKE_TEMP )/Dt:',dydx%lake_temp @@ -932,20 +947,20 @@ subroutine lake_sanity_check(y,reject_step,dydx,h,print_problems) write(unit=*,fmt='(a)') ' ' write(unit=*,fmt='(a)') ' 1. CANOPY AIR SPACE: ' write(unit=*,fmt='(a)') ' ' - write(unit=*,fmt='(6(a,1x))') ' MIN_THEIV',' MAX_THEIV',' MIN_SHV' & - ,' MAX_SHV',' MIN_RHV',' MAX_RHV' - write(unit=*,fmt='(6(es12.5,1x))') rk4min_can_theiv,rk4max_can_theiv & - ,rk4min_can_shv ,rk4max_can_shv & + write(unit=*,fmt='(4(a,1x))') ' MIN_SHV',' MAX_SHV',' MIN_RHV' & + ,' MAX_RHV' + write(unit=*,fmt='(4(es12.5,1x))') rk4min_can_shv ,rk4max_can_shv & ,rk4min_can_rhv ,rk4max_can_rhv write(unit=*,fmt='(a)') ' ' - write(unit=*,fmt='(4(a,1x))') ' MIN_TEMP',' MAX_TEMP',' MIN_THETA' & - ,' MAX_THETA' - write(unit=*,fmt='(4(es12.5,1x))') rk4min_can_temp ,rk4max_can_temp & - ,rk4min_can_theta,rk4max_can_theta + write(unit=*,fmt='(4(a,1x))') ' MIN_TEMP',' MAX_TEMP',' MIN_THETA' & + ,' MAX_THETA','MIN_ENTHALPY','MAX_ENTHALPY' + write(unit=*,fmt='(4(es12.5,1x))') rk4min_can_temp ,rk4max_can_temp & + ,rk4min_can_theta ,rk4max_can_theta & + ,rk4min_can_enthalpy,rk4max_can_enthalpy write(unit=*,fmt='(a)') ' ' - write(unit=*,fmt='(4(a,1x))') ' MIN_PRSS',' MAX_PRSS',' MIN_CO2' & + write(unit=*,fmt='(4(a,1x))') ' MIN_PRSS',' MAX_PRSS',' MIN_CO2' & ,' MAX_CO2' - write(unit=*,fmt='(4(es12.5,1x))') rk4min_can_prss ,rk4max_can_prss & + write(unit=*,fmt='(4(es12.5,1x))') rk4min_can_prss ,rk4max_can_prss & ,rk4min_can_co2 ,rk4max_can_co2 write(unit=*,fmt='(a)') ' ' write(unit=*,fmt='(78a)') ('-',k=1,78) @@ -977,6 +992,7 @@ subroutine print_lakesite(y,initp,htry) use lake_coms , only : lakesitetype & ! structure , lakemet ! ! intent(in) use ed_misc_coms, only : current_time ! ! intent(in) + use therm_lib8 , only : thetaeiv8 ! ! function implicit none !----- Arguments -----------------------------------------------------------------------! type(lakesitetype) , target :: y @@ -984,6 +1000,18 @@ subroutine print_lakesite(y,initp,htry) real(kind=8) , intent(in) :: htry !----- Local variables. ----------------------------------------------------------------! integer :: k + real(kind=8) :: y_can_rvap + real(kind=8) :: y_can_theiv + real(kind=8) :: initp_can_rvap + real(kind=8) :: initp_can_theiv + !---------------------------------------------------------------------------------------! + + !----- Find the ice-vapour equivalent potential temperature (output only). -------------! + initp_can_rvap = initp%can_shv / (1.d0 - initp%can_shv) + initp_can_theiv = thetaeiv8(initp%can_theta,initp%can_prss,initp%can_temp & + ,initp_can_rvap,initp_can_rvap) + y_can_rvap = y%can_shv / (1.d0 - y%can_shv) + y_can_theiv = thetaeiv8(y%can_theta,y%can_prss,y%can_temp,y_can_rvap,y_can_rvap) !---------------------------------------------------------------------------------------! @@ -1000,7 +1028,7 @@ subroutine print_lakesite(y,initp,htry) write (unit=*,fmt='(a)') ' ATMOSPHERIC CONDITIONS: ' write (unit=*,fmt='(a,1x,es12.4)') ' Air temperature : ',lakemet%atm_tmp write (unit=*,fmt='(a,1x,es12.4)') ' Air potential temp. : ',lakemet%atm_theta - write (unit=*,fmt='(a,1x,es12.4)') ' Air theta_Eiv : ',lakemet%atm_theiv + write (unit=*,fmt='(a,1x,es12.4)') ' Air spec. enthalpy : ',lakemet%atm_enthalpy write (unit=*,fmt='(a,1x,es12.4)') ' H2Ov mixing ratio : ',lakemet%atm_shv write (unit=*,fmt='(a,1x,es12.4)') ' H2Ov rel. humidity : ',lakemet%atm_rhv write (unit=*,fmt='(a,1x,es12.4)') ' CO2 mixing ratio : ',lakemet%atm_co2 @@ -1036,9 +1064,9 @@ subroutine print_lakesite(y,initp,htry) ,' CAN_RVAP',' CAN_RHV' - write (unit=*,fmt='(8(es12.4,1x))') y%can_rhos , y%can_theiv, y%can_theta & + write (unit=*,fmt='(8(es12.4,1x))') y%can_rhos , y_can_theiv, y%can_theta & , y%can_temp , y%can_shv , y%can_ssh & - , y%can_rvap , y%can_rhv + , y_can_rvap , y%can_rhv write (unit=*,fmt='(80a)') ('-',k=1,80) @@ -1073,9 +1101,9 @@ subroutine print_lakesite(y,initp,htry) ,' CAN_TEMP',' CAN_SHV',' CAN_SSH' & ,' CAN_RVAP',' CAN_RHV' - write (unit=*,fmt='(8(es12.4,1x))') initp%can_rhos , initp%can_theiv, initp%can_theta & + write (unit=*,fmt='(8(es12.4,1x))') initp%can_rhos , initp_can_theiv, initp%can_theta & , initp%can_temp , initp%can_shv , initp%can_ssh & - , initp%can_rvap , initp%can_rhv + , initp_can_rvap , initp%can_rhv write (unit=*,fmt='(80a)') ('-',k=1,80) @@ -1140,11 +1168,12 @@ subroutine print_lake_errmax(errmax,yerr,yscal,y,ytemp) ,' Rel.Error',' Abs.Error',' Scale' & ,'Problem(T|F)' - thiserr = abs(yerr%can_lntheta/yscal%can_lntheta) + thiserr = abs(yerr%can_enthalpy/yscal%can_enthalpy) errmax = max(errmax,thiserr) - troublemaker = large_error(yerr%can_theiv,yscal%can_theiv) - write(unit=*,fmt=onefmt) 'CAN_LNTHETA:',thiserr,ytemp%can_lntheta,y%can_lntheta & - ,yerr%can_lntheta,yscal%can_lntheta,troublemaker + troublemaker = large_error(yerr%can_enthalpy,yscal%can_enthalpy) + write(unit=*,fmt=onefmt) 'CAN_ENTHALPY:',thiserr,ytemp%can_enthalpy,y%can_enthalpy & + ,yerr%can_enthalpy,yscal%can_enthalpy & + ,troublemaker thiserr = abs(yerr%can_shv/yscal%can_shv) errmax = max(errmax,thiserr) diff --git a/BRAMS/src/ed2/edcp_lake_stepper.f90 b/BRAMS/src/ed2/edcp_lake_stepper.f90 index 07f54f014..fc0224c9f 100644 --- a/BRAMS/src/ed2/edcp_lake_stepper.f90 +++ b/BRAMS/src/ed2/edcp_lake_stepper.f90 @@ -103,7 +103,7 @@ subroutine integrate_lake(dtfull,htryio) ! Try a step of varying size. ! !---------------------------------------------------------------------------------! select case (integration_scheme) - case (0) + case (0,3) !------------------------------------------------------------------------------! ! Euler scheme. This is very simple so it won't have a routine by itself. ! ! Integrate, then update and correct diagnostic variables to avoid overshoot- ! @@ -119,12 +119,12 @@ subroutine integrate_lake(dtfull,htryio) !------------------------------------------------------------------------------! case (1) - call lake_heun(lake_buff%y,lake_buff%dydx,lake_buff%ytemp,lake_buff%yerr & - ,lake_buff%ak2,lake_buff%ak3,x,h,reject_step,reject_result) - case (2) call lake_rk4(lake_buff%y,lake_buff%dydx,lake_buff%ytemp,lake_buff%yerr & ,lake_buff%ak2,lake_buff%ak3,lake_buff%ak4,lake_buff%ak5 & ,lake_buff%ak6,lake_buff%ak7,x,h,reject_step,reject_result) + case (2) + call lake_heun(lake_buff%y,lake_buff%dydx,lake_buff%ytemp,lake_buff%yerr & + ,lake_buff%ak2,lake_buff%ak3,x,h,reject_step,reject_result) end select !---------------------------------------------------------------------------------! diff --git a/BRAMS/src/ed2/edcp_load_namelist.f90 b/BRAMS/src/ed2/edcp_load_namelist.f90 index 2bb233123..e579eea33 100644 --- a/BRAMS/src/ed2/edcp_load_namelist.f90 +++ b/BRAMS/src/ed2/edcp_load_namelist.f90 @@ -83,13 +83,15 @@ subroutine read_ednl(iunit,filename) use decomp_coms , only : n_decomp_lim & ! intent(out) , LloydTaylor ! ! intent(out) use disturb_coms , only : include_fire & ! intent(out) + , fire_parameter & ! intent(out) , ianth_disturb & ! intent(out) , lu_database & ! intent(out) , plantation_file & ! intent(out) , lu_rescale_file & ! intent(out) , treefall_disturbance_rate & ! intent(out) , time2canopy & ! intent(out) - , sm_fire ! ! intent(out) + , sm_fire & ! intent(out) + , min_patch_area ! ! intent(out) use pft_coms , only : include_these_pft & ! intent(out) , agri_stock & ! intent(out) , plantation_stock & ! intent(out) @@ -113,6 +115,7 @@ subroutine read_ednl(iunit,filename) , thsums_database & ! intent(out) , end_time & ! intent(out) , ivegt_dynamics & ! intent(out) + , ibigleaf & ! intent(out) , integration_scheme & ! intent(out) , ffilout & ! intent(out) , dtlsm & ! intent(out) @@ -208,6 +211,8 @@ subroutine read_ednl(iunit,filename) , leaf_min_patch_area => min_patch_area ! ! intent(in) use mem_radiate , only : radfrq ! ! intent(in) use consts_coms , only : day_sec ! ! intent(in) + use detailed_coms , only : idetailed & ! intent(in) + , patch_keep ! ! intent(in) implicit none !----- Arguments. ----------------------------------------------------------------------! integer , intent(in) :: iunit ! Namelist unit number @@ -223,22 +228,22 @@ subroutine read_ednl(iunit,filename) ,itoutput,isoutput,attach_metadata,outfast,outstate,ffilout,sfilout & ,ied_init_mode,edres,sfilin,veg_database,soil_database,lu_database & ,plantation_file,lu_rescale_file,thsums_database,soilstate_db & - ,soildepth_db,isoilstateinit,isoildepthflg,ivegt_dynamics & + ,soildepth_db,isoilstateinit,isoildepthflg,ivegt_dynamics,ibigleaf & ,integration_scheme,rk4_tolerance,ibranch_thermo,iphysiol,iallom & ,iphen_scheme,radint,radslp,repro_scheme,lapse_scheme,crown_mod & ,icanrad,ltrans_vis,ltrans_nir,lreflect_vis,lreflect_nir & ,orient_tree,orient_grass,clump_tree,clump_grass,decomp_scheme & ,h2o_plant_lim,vmfact_c3,vmfact_c4,mphoto_trc3,mphoto_tec3 & - ,mphoto_c4,bphoto_blc3,bphoto_nlc3,bphoto_nlc4,kw_grass & + ,mphoto_c4,bphoto_blc3,bphoto_nlc3,bphoto_c4,kw_grass & ,kw_tree,gamma_c3,gamma_c4,d0_grass,d0_tree,alpha_c3 & ,alpha_c4,klowco2in,rrffact,growthresp,lwidth_grass,lwidth_bltree & ,lwidth_nltree,q10_c3,q10_c4,thetacrit,quantum_efficiency_t & - ,n_plant_lim,n_decomp_lim,include_fire,sm_fire,ianth_disturb & - ,icanturb,include_these_pft,agri_stock,plantation_stock & - ,pft_1st_check,maxpatch,maxcohort,treefall_disturbance_rate & - ,time2canopy,iprintpolys,npvars,printvars,pfmtstr,ipmin,ipmax & - ,imetrad,iphenys1,iphenysf,iphenyf1,iphenyff,iedcnfgf,event_file & - ,phenpath + ,n_plant_lim,n_decomp_lim,include_fire,fire_parameter,sm_fire & + ,ianth_disturb,icanturb,include_these_pft,agri_stock & + ,plantation_stock,pft_1st_check,maxpatch,maxcohort,min_patch_area & + ,treefall_disturbance_rate,time2canopy,iprintpolys,npvars,printvars & + ,pfmtstr,ipmin,ipmax,imetrad,iphenys1,iphenysf,iphenyf1,iphenyff & + ,iedcnfgf,event_file,phenpath !----- Initialise some database variables with a non-sense path. -----------------------! soil_database (:) = undef_path @@ -298,6 +303,7 @@ subroutine read_ednl(iunit,filename) write (unit=*,fmt=*) ' isoilstateinit =',isoilstateinit write (unit=*,fmt=*) ' isoildepthflg =',isoildepthflg write (unit=*,fmt=*) ' ivegt_dynamics =',ivegt_dynamics + write (unit=*,fmt=*) ' ibigleaf =',ibigleaf write (unit=*,fmt=*) ' integration_scheme =',integration_scheme write (unit=*,fmt=*) ' rk4_tolerance =',rk4_tolerance write (unit=*,fmt=*) ' ibranch_thermo =',ibranch_thermo @@ -349,6 +355,7 @@ subroutine read_ednl(iunit,filename) write (unit=*,fmt=*) ' n_plant_lim =',n_plant_lim write (unit=*,fmt=*) ' n_decomp_lim =',n_decomp_lim write (unit=*,fmt=*) ' include_fire =',include_fire + write (unit=*,fmt=*) ' fire_parameter =',fire_parameter write (unit=*,fmt=*) ' sm_fire =',sm_fire write (unit=*,fmt=*) ' ianth_disturb =',ianth_disturb write (unit=*,fmt=*) ' icanturb =',icanturb @@ -359,6 +366,7 @@ subroutine read_ednl(iunit,filename) write (unit=*,fmt=*) ' maxsite =',maxsite write (unit=*,fmt=*) ' maxpatch =',maxpatch write (unit=*,fmt=*) ' maxcohort =',maxcohort + write (unit=*,fmt=*) ' min_patch_area =',min_patch_area write (unit=*,fmt=*) ' treefall_disturbance_rate =',treefall_disturbance_rate write (unit=*,fmt=*) ' time2canopy =',time2canopy write (unit=*,fmt=*) ' iprintpolys =',iprintpolys @@ -429,6 +437,10 @@ subroutine read_ednl(iunit,filename) ! outstate, the special flags cover all possibilities. slxclay = -1. ! This is not going to be used in coupled runs because the slxsand = -1. ! soil should come from lon/lat maps. + idetailed = 0 ! No detailed output in coupled runs (it is already too slow + ! with the normal output...) + patch_keep = 0 ! Keep all patches. + !---------------------------------------------------------------------------------------! !---------------------------------------------------------------------------------------! ! We make sure that the maximum number of sites per polygon in ED2 is equivalent ! diff --git a/BRAMS/src/ed2/edcp_met.f90 b/BRAMS/src/ed2/edcp_met.f90 index eb5bc03b6..59cd468c9 100644 --- a/BRAMS/src/ed2/edcp_met.f90 +++ b/BRAMS/src/ed2/edcp_met.f90 @@ -31,25 +31,20 @@ subroutine copy_atm2lsm(ifm,init) , iz1 & ! intent(in) , ja_1 & ! intent(in) , jz1 ! ! intent(in) - use rconstants , only : cpi & ! intent(in) - , cp & ! intent(in) - , p00 & ! intent(in) - , p00i & ! intent(in) - , rocp & ! intent(in) - , cliq & ! intent(in) - , alli & ! intent(in) - , cice & ! intent(in) - , t3ple & ! intent(in) + use rconstants , only : t3ple & ! intent(in) , t00 & ! intent(in) - , cpor & ! intent(in) - , wdnsi & ! intent(in) - , tsupercool ! ! intent(in) + , wdnsi ! ! intent(in) use ed_node_coms , only : mynum ! ! intent(in) use mem_edcp , only : co2_offset & ! intent(in) , atm_co2_min ! ! intent(in) - use therm_lib , only : thetaeiv & ! intent(in) - , rehuil & ! intent(in) - , ptrh2rvapil ! ! intent(in) + use therm_lib , only : thetaeiv & ! function + , rehuil & ! function + , ptrh2rvapil & ! function + , press2exner & ! function + , exner2press & ! function + , extemp2theta & ! function + , extheta2temp & ! function + , tl2uint ! ! function use met_driver_coms , only : imetrad & ! intent(in) , rlong_min & ! intent(in) , atm_rhv_min & ! intent(in) @@ -189,8 +184,8 @@ subroutine copy_atm2lsm(ifm,init) par_beam(i,j) = fvis_beam_def * (radiate_g(ifm)%rshort(i,j)-rshortd(i,j)) par_diff(i,j) = fvis_diff_def * rshortd(i,j) case (2) - press = p00 * (cpi * pi0_mean(i,j))**cpor - + press = exner2press(pi0_mean(i,j)) + call short_bdown_weissnorman(radiate_g(ifm)%rshort_diffuse(i,j),press & ,radiate_g(ifm)%cosz(i,j),par_beam(i,j) & ,par_diff(i,j),nir_beam(i,j),nir_diff(i,j) & @@ -303,7 +298,7 @@ subroutine copy_atm2lsm(ifm,init) par_beam(i,j) = fvis_beam_def * (radiate_g(ifm)%rshort(i,j)-rshortd(i,j)) par_diff(i,j) = fvis_diff_def * rshortd(i,j) case (2) - press = p00 * (cpi * pi0_mean(i,j))**cpor + press = exner2press(pi0_mean(i,j)) call short_bdown_weissnorman(radiate_g(ifm)%rshort_diffuse(i,j),press & ,radiate_g(ifm)%cosz(i,j),par_beam(i,j) & @@ -340,7 +335,7 @@ subroutine copy_atm2lsm(ifm,init) cgrid%met(ipy)%rlong = radiate_g(ifm)%rlong(ix,iy) !----- Converting Exner function to pressure. ---------------------------------------! cgrid%met(ipy)%exner = pi0_mean(ix,iy) - cgrid%met(ipy)%prss = p00 * (cpi * cgrid%met(ipy)%exner)**cpor + cgrid%met(ipy)%prss = exner2press(cgrid%met(ipy)%exner) !----- Finding the actual height above ground for 2nd level. ------------------------! cgrid%met(ipy)%geoht = (zt(k2w)-zm(k1w)) * grid_g(ifm)%rtgt(ix,iy) @@ -358,7 +353,8 @@ subroutine copy_atm2lsm(ifm,init) !------------------------------------------------------------------------------------! cgrid%met(ipy)%atm_theta = theta_mean(ix,iy) - cgrid%met(ipy)%atm_tmp = cpi * cgrid%met(ipy)%atm_theta * cgrid%met(ipy)%exner + cgrid%met(ipy)%atm_tmp = extheta2temp( cgrid%met(ipy)%exner & + , cgrid%met(ipy)%atm_theta ) cgrid%met(ipy)%atm_co2 = max(atm_co2_min,co2p_mean(ix,iy) + co2_offset) @@ -368,7 +364,7 @@ subroutine copy_atm2lsm(ifm,init) ! atm_rhv_min and atm_rhv_max (from met_driver_coms.f90, and defined at the ! ! init_met_params subroutine in ed_params.f90). ! !------------------------------------------------------------------------------------! - relhum = rehuil(cgrid%met(ipy)%prss,cgrid%met(ipy)%atm_tmp,rv_mean(ix,iy)) + relhum = rehuil(cgrid%met(ipy)%prss,cgrid%met(ipy)%atm_tmp,rv_mean(ix,iy),.false.) !------------------------------------------------------------------------------------! ! Check whether the relative humidity is off-bounds. If it is, then we re- ! ! calculate mixing ratio exactly at the limit, then convert it to specific humidity. ! @@ -377,11 +373,13 @@ subroutine copy_atm2lsm(ifm,init) !------------------------------------------------------------------------------------! if (relhum < atm_rhv_min) then relhum = atm_rhv_min - rv_mean(ix,iy) = ptrh2rvapil(relhum,cgrid%met(ipy)%prss,cgrid%met(ipy)%atm_tmp) + rv_mean(ix,iy) = ptrh2rvapil(relhum,cgrid%met(ipy)%prss,cgrid%met(ipy)%atm_tmp & + ,.false.) rtp_mean(ix,iy) = max(rtp_mean(ix,iy), rv_mean(ix,iy)) elseif (relhum > atm_rhv_max) then relhum = atm_rhv_max - rv_mean(ix,iy) = ptrh2rvapil(relhum,cgrid%met(ipy)%prss,cgrid%met(ipy)%atm_tmp) + rv_mean(ix,iy) = ptrh2rvapil(relhum,cgrid%met(ipy)%prss,cgrid%met(ipy)%atm_tmp & + ,.false.) rtp_mean(ix,iy) = max(rtp_mean(ix,iy), rv_mean(ix,iy)) end if !----- Find the specific humidity. --------------------------------------------------! @@ -391,7 +389,7 @@ subroutine copy_atm2lsm(ifm,init) !----- Find the ice-vapour equivalent potential temperature. ------------------------! cgrid%met(ipy)%atm_theiv = thetaeiv(cgrid%met(ipy)%atm_theta,cgrid%met(ipy)%prss & ,cgrid%met(ipy)%atm_tmp,rtp_mean(ix,iy) & - ,rtp_mean(ix,iy),-9) + ,rtp_mean(ix,iy)) end do polyloop1st !----- Filling the precipitation arrays. -----------------------------------------------! @@ -431,8 +429,9 @@ subroutine copy_atm2lsm(ifm,init) ! temperature, so it will respect the ideal gas law and first law of thermo- ! ! dynamics. ! !---------------------------------------------------------------------------------! - cpoly%met(isi)%exner = cp * (p00i * cpoly%met(isi)%prss) **rocp - cpoly%met(isi)%atm_theta = cp * cpoly%met(isi)%atm_tmp / cpoly%met(isi)%exner + cpoly%met(isi)%exner = press2exner (cpoly%met(isi)%prss) + cpoly%met(isi)%atm_theta = extemp2theta( cpoly%met(isi)%exner & + , cpoly%met(isi)%atm_tmp ) !---------------------------------------------------------------------------------! ! Check the relative humidity associated with the current pressure, temper- ! @@ -440,26 +439,31 @@ subroutine copy_atm2lsm(ifm,init) ! the variables atm_rhv_min and atm_rhv_max (from met_driver_coms.f90, and ! ! defined at the init_met_params subroutine in ed_params.f90). ! !---------------------------------------------------------------------------------! - rvaux = cpoly%met(isi)%atm_shv / (1. - cpoly%met(isi)%atm_shv) - relhum = rehuil(cpoly%met(isi)%prss,cpoly%met(isi)%atm_tmp,rvaux) + relhum = rehuil(cpoly%met(isi)%prss,cpoly%met(isi)%atm_tmp,cpoly%met(isi)%atm_shv & + ,.true.) !---------------------------------------------------------------------------------! ! Check whether the relative humidity is off-bounds. If it is, then we re- ! ! calculate the mixing ratio and convert to specific humidity. ! !---------------------------------------------------------------------------------! if (relhum < atm_rhv_min) then relhum = atm_rhv_min - rvaux = ptrh2rvapil(relhum,cpoly%met(isi)%prss,cpoly%met(isi)%atm_tmp) - cpoly%met(isi)%atm_shv = rvaux / (1. + rvaux) + cpoly%met(isi)%atm_shv = ptrh2rvapil( relhum & + , cpoly%met(isi)%prss & + , cpoly%met(isi)%atm_tmp & + , .true.) elseif (relhum > atm_rhv_max) then relhum = atm_rhv_max - rvaux = ptrh2rvapil(relhum,cpoly%met(isi)%prss,cpoly%met(isi)%atm_tmp) - cpoly%met(isi)%atm_shv = rvaux / (1. + rvaux) + cpoly%met(isi)%atm_shv = ptrh2rvapil( relhum & + , cpoly%met(isi)%prss & + , cpoly%met(isi)%atm_tmp & + , .true.) end if !---------------------------------------------------------------------------------! !----- Find the atmospheric equivalent potential temperature. --------------------! + rvaux = cpoly%met(isi)%atm_shv / (1.0 - cpoly%met(isi)%atm_shv) cpoly%met(isi)%atm_theiv = thetaeiv(cpoly%met(isi)%atm_theta,cpoly%met(isi)%prss & - ,cpoly%met(isi)%atm_tmp,rvaux,rvaux,-59) + ,cpoly%met(isi)%atm_tmp,rvaux,rvaux) !----- Solar radiation -----------------------------------------------------------! cpoly%met(isi)%rshort_diffuse = cpoly%met(isi)%par_diffuse & @@ -528,9 +532,9 @@ subroutine copy_atm2lsm(ifm,init) ! point) multiplied by the ice fraction. ! !---------------------------------------------------------------------------------! cpoly%met(isi)%qpcpg = max(0.0, cpoly%met(isi)%pcpg) & - * ( (1.0-fice) * cliq * ( max(t3ple,cpoly%met(isi)%atm_tmp) & - - tsupercool) & - + fice *cice * min(cpoly%met(isi)%atm_tmp,t3ple)) + * ( (1.0 - fice) & + * tl2uint(max(t3ple,cpoly%met(isi)%atm_tmp),1.0) & + + fice * tl2uint(min(cpoly%met(isi)%atm_tmp,t3ple),0.0) ) !---------------------------------------------------------------------------------! end do siteloop @@ -573,8 +577,6 @@ subroutine fill_site_precip(ifm,cgrid,m2,m3,ia,iz,ja,jz,init) use micphys , only : availcat ! ! intent(in) use therm_lib , only : bulk_on ! ! intent(in) use mem_basic , only : basic_g ! ! structure - use rconstants , only : cpi & ! intent(in) - , cliq ! ! intent(in) use ed_state_vars, only : edtype ! ! structure use mem_edcp , only : ed_precip_g ! ! structure use ed_misc_coms , only : dtlsm ! ! intent(in) @@ -960,17 +962,16 @@ subroutine initialize_ed2leaf(ifm) , if_adap & ! intent(in) , jdim & ! intent(in) , npatch ! ! intent(in) - use rconstants , only : cpi & ! intent(in) - , p00 & ! intent(in) - , cpor ! ! intent(in) use leaf_coms , only : can_depth ! ! intent(in) use mem_cuparm , only : cuparm_g & ! structure , nnqparm ! ! intent(in) use micphys , only : availcat ! ! intent(in) use mem_micro , only : micro_g ! ! structure - use therm_lib , only : reducedpress & ! function + use therm_lib , only : bulk_on & ! intent(in) + , reducedpress & ! function , thetaeiv & ! function - , bulk_on ! ! intent(in) + , exner2press & ! function + , extheta2temp ! ! function use ed_state_vars, only : edgrid_g & ! intent(in) , edtype ! ! structure implicit none @@ -1010,8 +1011,7 @@ subroutine initialize_ed2leaf(ifm) allocate (rv_mean (mxp,myp)) allocate (rtp_mean (mxp,myp)) allocate (geoht (mxp,myp)) - - + !---------------------------------------------------------------------------------------! @@ -1071,19 +1071,19 @@ subroutine initialize_ed2leaf(ifm) do j=1,myp do i=1,mxp - !----- Finding the atmospheric pressure and specific humidity. -------------------! - atm_prss = p00 * (cpi * pi0_mean(i,j)) ** cpor + !----- Find the atmospheric pressure and specific humidity. ----------------------! + atm_prss = exner2press(pi0_mean(i,j)) atm_shv = rtp_mean(i,j) / (1. + rtp_mean(i,j)) - atm_temp = cpi * pi0_mean(i,j) * theta_mean(i,j) + atm_temp = extheta2temp(pi0_mean(i,j),theta_mean(i,j)) - !----- Computing the state variables. --------------------------------------------! + !----- Compute the state variables. ----------------------------------------------! leaf_g(ifm)%can_theta(i,j,1) = theta_mean(i,j) leaf_g(ifm)%can_rvap (i,j,1) = rv_mean(i,j) leaf_g(ifm)%can_prss (i,j,1) = reducedpress(atm_prss,theta_mean(i,j),atm_shv & ,geoht(i,j),theta_mean(i,j) & ,atm_shv,can_depth) leaf_g(ifm)%can_theiv(i,j,1) = thetaeiv(thil_mean(i,j),atm_prss,atm_temp & - ,rtp_mean(i,j),rtp_mean(i,j),-7) + ,rtp_mean(i,j),rtp_mean(i,j)) leaf_g(ifm)%gpp (i,j,1) = 0.0 leaf_g(ifm)%resphet (i,j,1) = 0.0 leaf_g(ifm)%plresp (i,j,1) = 0.0 @@ -1117,6 +1117,7 @@ subroutine initialize_ed2leaf(ifm) deallocate (rv_mean ) deallocate (rtp_mean ) deallocate (geoht ) + !---------------------------------------------------------------------------------------! return end subroutine initialize_ed2leaf @@ -1558,10 +1559,13 @@ subroutine copy_avgvars_to_leaf(ifm) use mem_grid , only : nzg & ! intent(in) , nzs ! ! intent(in) use rconstants , only : t3ple & ! intent(in) - , cliqvlme & ! intent(in) - , cicevlme & ! intent(in) - , allivlme & ! intent(in) - , alvl ! ! intent(in) + , wdns ! ! intent(in) + use therm_lib , only : alvl & ! intent(in) + , alvi & ! intent(in) + , uint2tl & ! intent(in) + , uextcm2tl & ! intent(in) + , press2exner & ! intent(in) + , extheta2temp ! ! intent(in) use soil_coms , only : soil & ! intent(in) , tiny_sfcwater_mass ! ! intent(in) use ed_misc_coms , only : frqsum ! ! intent(in) @@ -1586,7 +1590,14 @@ subroutine copy_avgvars_to_leaf(ifm) integer :: k integer :: idbh integer :: ipft + integer :: nsoil real :: site_area_i + real :: ground_temp + real :: ground_fliq + real :: veg_temp + real :: veg_fliq + real :: can_temp + real :: can_exner !---------------------------------------------------------------------------------------! !----- Set the pointers ----------------------------------------------------------------! @@ -1661,7 +1672,9 @@ subroutine copy_avgvars_to_leaf(ifm) - !----- Update vegetation properties. ---------------------------------------------! + !---------------------------------------------------------------------------------! + ! Update vegetation properties. ! + !---------------------------------------------------------------------------------! leaf_g(ifm)%veg_water (ix,iy,ilp) = cpoly%avg_leaf_water (isi) & + cpoly%avg_wood_water (isi) leaf_g(ifm)%veg_hcap (ix,iy,ilp) = cpoly%avg_leaf_hcap (isi) & @@ -1670,6 +1683,9 @@ subroutine copy_avgvars_to_leaf(ifm) + cpoly%avg_wood_energy (isi) leaf_g(ifm)%veg_lai (ix,iy,ilp) = cpoly%lai(isi) leaf_g(ifm)%veg_tai (ix,iy,ilp) = cpoly%lai(isi) + cgrid%wai(isi) + !---------------------------------------------------------------------------------! + + !----- Fill above ground biomass by integrating all PFTs and DBH classes. --------! leaf_g(ifm)%veg_agb(ix,iy,ilp) = 0. @@ -1679,6 +1695,9 @@ subroutine copy_avgvars_to_leaf(ifm) + cpoly%agb(ipft,idbh,isi) end do end do + !---------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------! ! Update canopy air properties. ! @@ -1695,16 +1714,65 @@ subroutine copy_avgvars_to_leaf(ifm) + !---------------------------------------------------------------------------------! + ! Temperature and liquid fraction of surfaces. We need them to find the ! + ! mean latent heat of vapourisation between leaves/ground and the canopy air ! + ! space. ! + !---------------------------------------------------------------------------------! + !----- Ground temperature. -------------------------------------------------------! + if (leaf_g(ifm)%sfcwater_nlev(ix,iy,ilp) == 0.) then + !------ There is no temporary surface water. Use top soil temperature. -------! + nsoil = cpoly%ntext_soil(nzg,isi) + call uextcm2tl(cgrid%avg_soil_energy(nzg,isi) & + ,cgrid%avg_soil_water(nzg,isi) * wdns,soil(nsoil)%slcpd & + ,ground_temp,ground_fliq ) + !------------------------------------------------------------------------------! + else + !------ There is a temporary surface water. Use average temperature. ---------! + call uint2tl(cgrid%avg_sfcw_energy(isi),ground_temp,ground_fliq) + !------------------------------------------------------------------------------! + end if + !----- Vegetation temperature. Here we must check if there are plants. ----------! + if (leaf_g(ifm)%veg_hcap(ix,iy,ilp) > 0.) then + !----- There is some plant here. ----------------------------------------------! + call uextcm2tl(leaf_g(ifm)%veg_energy(ix,iy,ilp) & + ,leaf_g(ifm)%veg_water (ix,iy,ilp) & + ,leaf_g(ifm)%veg_hcap (ix,iy,ilp) & + ,veg_temp,veg_fliq ) + !------------------------------------------------------------------------------! + else + !----- Site is empty. Use canopy air space instead. --------------------------! + can_exner = press2exner(cpoly%avg_can_prss(isi)) + can_temp = extheta2temp(can_exner,leaf_g(ifm)%can_theta(ix,iy,ilp)) + veg_temp = can_temp + if (veg_temp == t3ple) then + veg_fliq = 0.5 + elseif (veg_temp > t3ple) then + veg_fliq = 1.0 + else + veg_fliq = 0.0 + end if + !------------------------------------------------------------------------------! + end if + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! ! Copy the fluxes, which will be used for output only. ! !---------------------------------------------------------------------------------! leaf_g(ifm)%sensible_gc(ix,iy,ilp) = cpoly%avg_sensible_gc(isi) leaf_g(ifm)%sensible_vc(ix,iy,ilp) = ( cpoly%avg_sensible_lc(isi) & + cpoly%avg_sensible_wc(isi) ) - leaf_g(ifm)%evap_gc (ix,iy,ilp) = cpoly%avg_vapor_gc(isi) * alvl + leaf_g(ifm)%evap_gc (ix,iy,ilp) = cpoly%avg_vapor_gc(isi) & + * ( ground_fliq * alvl(ground_temp) & + + (1.0 - ground_fliq) * alvi(ground_temp) ) leaf_g(ifm)%evap_vc (ix,iy,ilp) = ( cpoly%avg_vapor_lc(isi) & - + cpoly%avg_vapor_wc(isi) ) * alvl - leaf_g(ifm)%transp (ix,iy,ilp) = cpoly%avg_transp(isi) * alvl + + cpoly%avg_vapor_wc(isi) ) & + * ( veg_fliq * alvl(veg_temp) & + + (1.0 - veg_fliq) * alvi(veg_temp) ) + !----- Transpiration only happens from liquid phase to vapour. -------------------! + leaf_g(ifm)%transp (ix,iy,ilp) = cpoly%avg_transp(isi) * alvl(veg_temp) !---------------------------------------------------------------------------------! diff --git a/BRAMS/src/ed2/edcp_met_init.f90 b/BRAMS/src/ed2/edcp_met_init.f90 index 94f312c8d..99ff8b600 100644 --- a/BRAMS/src/ed2/edcp_met_init.f90 +++ b/BRAMS/src/ed2/edcp_met_init.f90 @@ -65,12 +65,9 @@ subroutine leaf2ed_soil_moist_energy(cgrid,ifm) use grid_coms , only : nzg & ! intent(in) , nzs ! ! intent(in) use ed_therm_lib , only : ed_grndvap ! ! subroutine - use therm_lib8 , only : qwtk8 ! ! subroutine - use therm_lib , only : qwtk ! ! subroutine - use rconstants , only : wdns & ! intent(in) - , tsupercool & ! intent(in) - , cicevlme & ! intent(in) - , cliqvlme ! ! intent(in) + use therm_lib , only : uextcm2tl & ! subroutine + , cmtl2uext ! ! function + use rconstants , only : wdns ! ! intent(in) use mem_leaf , only : leaf_g ! ! structure use leaf_coms , only : slcpd ! ! intent(in) use soil_coms , only : soil ! ! intent(in) @@ -138,9 +135,9 @@ subroutine leaf2ed_soil_moist_energy(cgrid,ifm) !---------------------------------------------------------------------------------! do k=1,nzg lsoil_text(k) =nint(leaf_g(ifm)%soil_text(k,ix,iy,ilp)) - call qwtk(leaf_g(ifm)%soil_energy(k,ix,iy,ilp) & - ,leaf_g(ifm)%soil_water(k,ix,iy,ilp)*wdns & - ,slcpd(lsoil_text(k)),lsoil_temp(k),lsoil_fliq(k)) + call uextcm2tl(leaf_g(ifm)%soil_energy(k,ix,iy,ilp) & + ,leaf_g(ifm)%soil_water(k,ix,iy,ilp)*wdns & + ,slcpd(lsoil_text(k)),lsoil_temp(k),lsoil_fliq(k)) end do !---------------------------------------------------------------------------------! @@ -150,15 +147,15 @@ subroutine leaf2ed_soil_moist_energy(cgrid,ifm) cpatch => csite%patch(ipa) do k=1,nzg - + ntext = cpoly%ntext_soil(k,isi) !---------------------------------------------------------------------------! ! Soil water. Ensuring that the initial condition is within the accept- ! ! able range. ! !---------------------------------------------------------------------------! - csite%soil_water(k,ipa) = max(soil(ntext)%soilcp & - ,min(soil(ntext)%slmsts & - ,leaf_g(ifm)%soil_water(k,ix,iy,ilp) ) ) + csite%soil_water(k,ipa) = max( soil(ntext)%soilcp & + , min(soil(ntext)%slmsts & + ,leaf_g(ifm)%soil_water(k,ix,iy,ilp) ) ) !---------------------------------------------------------------------------! ! Soil temperature and liquid fraction. Simply use what we found a few ! @@ -173,11 +170,10 @@ subroutine leaf2ed_soil_moist_energy(cgrid,ifm) ! Soil energy. Now that temperature, moisture and liquid partition are ! ! set, simply use the definition of internal energy to find it. ! !---------------------------------------------------------------------------! - csite%soil_energy(k,ipa) = soil(ntext)%slcpd * csite%soil_tempk(k,ipa) & - + csite%soil_water(k,ipa) & - * ( fice * cicevlme * csite%soil_tempk(k,ipa) & - + csite%soil_fracliq(k,ipa) * cliqvlme & - * (csite%soil_tempk(k,ipa) - tsupercool) ) + csite%soil_energy(k,ipa) = cmtl2uext( soil(ntext)%slcpd & + , csite%soil_water (k,ipa) * wdns & + , csite%soil_tempk (k,ipa) & + , csite%soil_fracliq(k,ipa) ) end do !----- Initialising surface snow/pond layers with nothing as default. ---------! diff --git a/BRAMS/src/ed2/edcp_model.f90 b/BRAMS/src/ed2/edcp_model.f90 index cfa918ea1..936267846 100644 --- a/BRAMS/src/ed2/edcp_model.f90 +++ b/BRAMS/src/ed2/edcp_model.f90 @@ -243,6 +243,8 @@ subroutine ed_coup_model(ifm) call rk4_timestep(edgrid_g(ifm),ifm) case (2) call heun_timestep(edgrid_g(ifm)) + case (3) + call hybrid_timestep(edgrid_g(ifm)) end select !---------------------------------------------------------------------------------------! diff --git a/BRAMS/src/ed2/edcp_mpiutils.f90 b/BRAMS/src/ed2/edcp_mpiutils.f90 index ad4a1ede7..74e0cf5e3 100644 --- a/BRAMS/src/ed2/edcp_mpiutils.f90 +++ b/BRAMS/src/ed2/edcp_mpiutils.f90 @@ -38,6 +38,7 @@ subroutine masterput_ednl(mainnum) , ied_init_mode & ! intent(in) , thsums_database & ! intent(in) , ivegt_dynamics & ! intent(in) + , ibigleaf & ! intent(in) , integration_scheme & ! intent(in) , end_time & ! intent(in) , current_time & ! intent(in) @@ -138,13 +139,15 @@ subroutine masterput_ednl(mainnum) , plantation_stock & ! intent(in) , pft_1st_check ! ! intent(in) use disturb_coms , only : include_fire & ! intent(in) + , fire_parameter & ! intent(in) , ianth_disturb & ! intent(in) , lu_database & ! intent(in) , plantation_file & ! intent(in) , lu_rescale_file & ! intent(in) , treefall_disturbance_rate & ! intent(in) , time2canopy & ! intent(in) - , sm_fire ! ! intent(in) + , sm_fire & ! intent(in) + , min_patch_area ! ! intent(in) use optimiz_coms , only : ioptinpt ! ! intent(in) use canopy_layer_coms , only : crown_mod ! ! intent(in) use canopy_radiation_coms, only : icanrad & ! intent(in) @@ -171,6 +174,8 @@ subroutine masterput_ednl(mainnum) , ribmax & ! intent(in) , leaf_maxwhc ! ! intent(in) use mem_edcp , only : co2_offset ! ! intent(in) + use detailed_coms , only : idetailed & ! intent(in) + , patch_keep ! ! intent(in) implicit none !----- Standard common blocks. ---------------------------------------------------------! include 'mpif.h' @@ -233,6 +238,7 @@ subroutine masterput_ednl(mainnum) call MPI_Bcast(isoildepthflg,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(isoilbc,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(ivegt_dynamics,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) + call MPI_Bcast(ibigleaf,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(integration_scheme,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(rk4_tolerance,1,MPI_REAL,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(ibranch_thermo,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) @@ -284,6 +290,7 @@ subroutine masterput_ednl(mainnum) call MPI_Bcast(n_plant_lim,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(n_decomp_lim,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(include_fire,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) + call MPI_Bcast(fire_parameter,1,MPI_REAL,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(sm_fire,1,MPI_REAL,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(ianth_disturb,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(icanturb,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) @@ -296,6 +303,7 @@ subroutine masterput_ednl(mainnum) call MPI_Bcast(maxpatch,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(maxcohort,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(min_site_area,1,MPI_REAL,mainnum,MPI_COMM_WORLD,ierr) + call MPI_Bcast(min_patch_area,1,MPI_REAL,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(treefall_disturbance_rate,1,MPI_REAL,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(time2canopy,1,MPI_REAL,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(runoff_time,1,MPI_REAL,mainnum,MPI_COMM_WORLD,ierr) @@ -377,6 +385,10 @@ subroutine masterput_ednl(mainnum) call MPI_Bcast(ribmax,1,MPI_REAL,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(leaf_maxwhc,1,MPI_REAL,mainnum,MPI_COMM_WORLD,ierr) + + call MPI_Bcast(idetailed,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) + call MPI_Bcast(patch_keep,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) + return end subroutine masterput_ednl !==========================================================================================! @@ -425,6 +437,7 @@ subroutine nodeget_ednl(master_num) , ied_init_mode & ! intent(out) , thsums_database & ! intent(out) , ivegt_dynamics & ! intent(out) + , ibigleaf & ! intent(out) , integration_scheme & ! intent(out) , end_time & ! intent(out) , current_time & ! intent(out) @@ -525,13 +538,15 @@ subroutine nodeget_ednl(master_num) , plantation_stock & ! intent(out) , pft_1st_check ! ! intent(out) use disturb_coms , only : include_fire & ! intent(out) + , fire_parameter & ! intent(out) , ianth_disturb & ! intent(out) , lu_database & ! intent(out) , plantation_file & ! intent(out) , lu_rescale_file & ! intent(out) , treefall_disturbance_rate & ! intent(out) , time2canopy & ! intent(out) - , sm_fire ! ! intent(out) + , sm_fire & ! intent(out) + , min_patch_area ! ! intent(out) use optimiz_coms , only : ioptinpt ! ! intent(out) use canopy_layer_coms , only : crown_mod ! ! intent(out) use canopy_radiation_coms, only : icanrad & ! intent(out) @@ -558,7 +573,8 @@ subroutine nodeget_ednl(master_num) , ribmax & ! intent(out) , leaf_maxwhc ! ! intent(out) use mem_edcp , only : co2_offset ! ! intent(out) - + use detailed_coms , only : idetailed & ! intent(out) + , patch_keep ! ! intent(out) implicit none !----- Standard common blocks. ---------------------------------------------------------! include 'mpif.h' @@ -623,6 +639,7 @@ subroutine nodeget_ednl(master_num) call MPI_Bcast(isoildepthflg,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(isoilbc,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(ivegt_dynamics,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) + call MPI_Bcast(ibigleaf,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(integration_scheme,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(rk4_tolerance,1,MPI_REAL,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(ibranch_thermo,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) @@ -674,6 +691,7 @@ subroutine nodeget_ednl(master_num) call MPI_Bcast(n_plant_lim,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(n_decomp_lim,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(include_fire,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) + call MPI_Bcast(fire_parameter,1,MPI_REAL,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(sm_fire,1,MPI_REAL,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(ianth_disturb,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(icanturb,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) @@ -686,6 +704,7 @@ subroutine nodeget_ednl(master_num) call MPI_Bcast(maxpatch,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(maxcohort,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(min_site_area,1,MPI_REAL,master_num,MPI_COMM_WORLD,ierr) + call MPI_Bcast(min_patch_area,1,MPI_REAL,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(treefall_disturbance_rate,1,MPI_REAL,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(time2canopy,1,MPI_REAL,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(runoff_time,1,MPI_REAL,master_num,MPI_COMM_WORLD,ierr) @@ -767,6 +786,9 @@ subroutine nodeget_ednl(master_num) call MPI_Bcast(ribmax,1,MPI_REAL,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(leaf_maxwhc,1,MPI_REAL,master_num,MPI_COMM_WORLD,ierr) + call MPI_Bcast(idetailed,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) + call MPI_Bcast(patch_keep,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) + return end subroutine nodeget_ednl !==========================================================================================! diff --git a/BRAMS/src/ed2/edcp_para_init.f90 b/BRAMS/src/ed2/edcp_para_init.f90 index 823724da6..a6261ae5c 100644 --- a/BRAMS/src/ed2/edcp_para_init.f90 +++ b/BRAMS/src/ed2/edcp_para_init.f90 @@ -79,12 +79,14 @@ subroutine edcp_get_work(ifm,nxp,nyp,inode,mxp,myp,ia,iz,i0,ja,jz,j0) allocate(ncol_soil_list (maxsite,npoly)) allocate(ipcent_land (maxsite,npoly)) allocate(ipcent_soil (maxsite,npoly)) - - !----- Fill lat/lon lists. -------------------------------------------------------------! + !---------------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------------! + ! Fill in the longitude and latitude lists. ! + ! ! ! i index: West-East (longitude). It increases eastwards. ! ! j index: South-North (latitude). It increases northwards. ! !---------------------------------------------------------------------------------------! diff --git a/BRAMS/src/ed2/lake_coms.f90 b/BRAMS/src/ed2/lake_coms.f90 index de299b35c..faa220bf3 100644 --- a/BRAMS/src/ed2/lake_coms.f90 +++ b/BRAMS/src/ed2/lake_coms.f90 @@ -13,11 +13,10 @@ module lake_coms type lakemettype real(kind=8) :: atm_rhos real(kind=8) :: atm_tmp + real(kind=8) :: atm_tmp_zcan real(kind=8) :: atm_theta - real(kind=8) :: atm_theiv - real(kind=8) :: atm_lntheta + real(kind=8) :: atm_enthalpy real(kind=8) :: atm_shv - real(kind=8) :: atm_rvap real(kind=8) :: atm_rhv real(kind=8) :: atm_co2 real(kind=8) :: atm_exner @@ -47,52 +46,51 @@ module lake_coms ! integration (the "canopy" air space and fluxes). ! !---------------------------------------------------------------------------------------! type lakesitetype - real(kind=8) :: can_temp - real(kind=8) :: can_theiv - real(kind=8) :: can_theta - real(kind=8) :: can_shv - real(kind=8) :: can_rhv - real(kind=8) :: can_ssh - real(kind=8) :: can_co2 - real(kind=8) :: can_prss - real(kind=8) :: can_rvap - real(kind=8) :: can_lntheta - real(kind=8) :: can_exner - real(kind=8) :: can_rhos - real(kind=8) :: can_depth - real(kind=8) :: lake_temp - real(kind=8) :: lake_fliq - real(kind=8) :: lake_shv - real(kind=8) :: lake_ssh - real(kind=8) :: lake_rough - real(kind=8) :: ustar - real(kind=8) :: tstar - real(kind=8) :: estar - real(kind=8) :: qstar - real(kind=8) :: cstar - real(kind=8) :: zeta - real(kind=8) :: ribulk - real(kind=8) :: gglake - real(kind=8) :: avg_vapor_gc - real(kind=8) :: avg_vapor_ac - real(kind=8) :: avg_sensible_gc - real(kind=8) :: avg_sensible_ac - real(kind=8) :: avg_carbon_gc - real(kind=8) :: avg_carbon_ac - real(kind=8) :: avg_carbon_st - real(kind=8) :: avg_sflux_u - real(kind=8) :: avg_sflux_w - real(kind=8) :: avg_sflux_v - real(kind=8) :: avg_sflux_t - real(kind=8) :: avg_sflux_r - real(kind=8) :: avg_sflux_c - real(kind=8) :: avg_rshort_gnd - real(kind=8) :: avg_albedt - real(kind=8) :: avg_rlongup - real(kind=8) :: avg_ustar - real(kind=8) :: avg_tstar - real(kind=8) :: avg_qstar - real(kind=8) :: avg_cstar + real(kind=8) :: can_temp ! Temperature [ K] + real(kind=8) :: can_enthalpy ! Canopy specific enthalpy [ J/kg] + real(kind=8) :: can_theta ! Potential Temperature [ K] + real(kind=8) :: can_shv ! Specific humidity [ kg/kg] + real(kind=8) :: can_rhv ! Relative humidity [ ---] + real(kind=8) :: can_ssh ! Saturation specific humidity [ kg/kg] + real(kind=8) :: can_co2 ! CO_2 mixing ratio [ µmol/mol] + real(kind=8) :: can_prss ! Pressure [ Pa] + real(kind=8) :: can_exner ! Exner function [ J/kg/K] + real(kind=8) :: can_rhos ! Canopy air density [ kg/m³] + real(kind=8) :: can_depth ! Canopy depth [ m] + real(kind=8) :: can_cp ! Specific heat [ J/kg/K] + real(kind=8) :: lake_temp ! Lake surface temperature [ K] + real(kind=8) :: lake_fliq ! Liquid water fraction [ ---] + real(kind=8) :: lake_shv ! Specific humidity at lake surface [ kg/kg] + real(kind=8) :: lake_ssh ! Sat. specific humdity at lake sfc. [ kg/kg] + real(kind=8) :: lake_rough ! Lake roughess [ m] + real(kind=8) :: ustar ! Friction velocity [ m/s] + real(kind=8) :: tstar ! Temperature gradient scale [ K] + real(kind=8) :: estar ! Enthalpy gradient scale [ J/kg] + real(kind=8) :: qstar ! Specific humidity gradient scale [ kg/kg] + real(kind=8) :: cstar ! CO2 gradient scale [ µmol/mol] + real(kind=8) :: zeta ! Normalised height [ ---] + real(kind=8) :: ribulk ! Bulk Richardson number [ ---] + real(kind=8) :: gglake ! Lake boundary layer conductance [ m/s] + real(kind=8) :: avg_vapor_gc ! Lake -> CAS vapour flux [ kg/m²/s] + real(kind=8) :: avg_vapor_ac ! Atmosphere -> CAS vapour flux [ kg/m²/s] + real(kind=8) :: avg_sensible_gc ! Lake -> CAS sensible heat flux [ W/m²] + real(kind=8) :: avg_sensible_ac ! Atmosphere -> CAS sens. heat flux [ W/m²] + real(kind=8) :: avg_carbon_gc ! Lake -> CAS CO2 flux [ µmol/m²/s] + real(kind=8) :: avg_carbon_ac ! Atmosphere -> CAS CO2 flux [ µmol/m²/s] + real(kind=8) :: avg_carbon_st ! CO2 storage [ µmol/m²/s] + real(kind=8) :: avg_sflux_u ! Momentum flux (zonal direction) [ m²/s²] + real(kind=8) :: avg_sflux_w ! Momentum flux (vertical direction) [ m²/s²] + real(kind=8) :: avg_sflux_v ! Momentum flux (meridional direction)[ m²/s²] + real(kind=8) :: avg_sflux_t ! Temperature eddy flux [ K m/s] + real(kind=8) :: avg_sflux_r ! Vapour eddy flux [ kg/kg m/s] + real(kind=8) :: avg_sflux_c ! CO2 eddy flux [µmol/mol m/s] + real(kind=8) :: avg_rshort_gnd ! Absorbed shortwave radiation [ W/m²] + real(kind=8) :: avg_albedt ! Ground albedo [ ----] + real(kind=8) :: avg_rlongup ! Upward longwave radiation [ W/m²] + real(kind=8) :: avg_ustar ! Mean u* [ m/s] + real(kind=8) :: avg_tstar ! Mean Theta* [ K] + real(kind=8) :: avg_qstar ! Mean q* [ kg/kg] + real(kind=8) :: avg_cstar ! Mean c* [ µmol/mol] end type lakesitetype !---------------------------------------------------------------------------------------! @@ -137,11 +135,17 @@ module lake_coms !---------------------------------------------------------------------------------------! - !----- "Canopy" water and heat capacity variables. -------------------------------------! - real(kind=8) :: wcapcan - real(kind=8) :: wcapcani - real(kind=8) :: hcapcani - real(kind=8) :: ccapcani + !---------------------------------------------------------------------------------------! + ! Canopy air space capacities. These variables are used to convert the intensive ! + ! version of canopy air space prognostic variables (specific enthalpy, water vapour ! + ! specific humidity and CO2 mixing ratio) into extensive variables. ! + !---------------------------------------------------------------------------------------! + real(kind=8) :: wcapcan ! Water capacity [ kg_air/m²gnd] + real(kind=8) :: hcapcan ! Enthalpy capacity [ kg_air/m²gnd] + real(kind=8) :: ccapcan ! CO2 capacity [ mol_air/m²gnd] + real(kind=8) :: wcapcani ! Inverse of water capacity [ m²gnd/kg_air] + real(kind=8) :: hcapcani ! Inverse of enthalpy capacity [ m²gnd/kg_air] + real(kind=8) :: ccapcani ! Inverse of CO2 capacity [ m²gnd/mol_air] !---------------------------------------------------------------------------------------! @@ -224,18 +228,17 @@ subroutine zero_lakesite(lake) !----- Reset the variables. ---------------------------------------------------------! lake%can_temp = 0.d0 - lake%can_theiv = 0.d0 + lake%can_enthalpy = 0.d0 lake%can_theta = 0.d0 lake%can_shv = 0.d0 lake%can_rhv = 0.d0 lake%can_ssh = 0.d0 lake%can_co2 = 0.d0 lake%can_prss = 0.d0 - lake%can_rvap = 0.d0 - lake%can_lntheta = 0.d0 lake%can_exner = 0.d0 lake%can_rhos = 0.d0 lake%can_depth = 0.d0 + lake%can_cp = 0.d0 lake%lake_temp = 0.d0 lake%lake_fliq = 0.d0 lake%lake_shv = 0.d0 @@ -296,23 +299,22 @@ subroutine clone_lakesite(lakein,lakeout) !----- Reset the variables. ---------------------------------------------------------! lakeout%can_temp = lakein%can_temp - lakeout%can_theiv = lakein%can_theiv + lakeout%can_enthalpy = lakein%can_enthalpy lakeout%can_theta = lakein%can_theta lakeout%can_shv = lakein%can_shv lakeout%can_rhv = lakein%can_rhv lakeout%can_ssh = lakein%can_ssh lakeout%can_co2 = lakein%can_co2 lakeout%can_prss = lakein%can_prss - lakeout%can_rvap = lakein%can_rvap - lakeout%can_lntheta = lakein%can_lntheta lakeout%can_exner = lakein%can_exner lakeout%can_rhos = lakein%can_rhos lakeout%can_depth = lakein%can_depth - lakeout%lake_temp = lakein%lake_temp - lakeout%lake_fliq = lakein%lake_fliq - lakeout%lake_shv = lakein%lake_shv - lakeout%lake_ssh = lakein%lake_ssh - lakeout%lake_rough = lakein%lake_rough + lakeout%can_cp = lakein%can_cp + lakeout%lake_temp = lakein%lake_temp + lakeout%lake_fliq = lakein%lake_fliq + lakeout%lake_shv = lakein%lake_shv + lakeout%lake_ssh = lakein%lake_ssh + lakeout%lake_rough = lakein%lake_rough lakeout%ustar = lakein%ustar lakeout%tstar = lakein%tstar lakeout%estar = lakein%estar @@ -370,7 +372,7 @@ subroutine integ_lakesite(lake,dlakedt,dtim) !----- Integrate the variables. -----------------------------------------------------! lake%can_shv = lake%can_shv + dtim * dlakedt%can_shv lake%can_co2 = lake%can_co2 + dtim * dlakedt%can_co2 - lake%can_lntheta = lake%can_lntheta + dtim * dlakedt%can_lntheta + lake%can_enthalpy = lake%can_enthalpy + dtim * dlakedt%can_enthalpy lake%lake_temp = lake%lake_temp + dtim * dlakedt%lake_temp lake%avg_vapor_gc = lake%avg_vapor_gc + dtim * dlakedt%avg_vapor_gc lake%avg_vapor_ac = lake%avg_vapor_ac + dtim * dlakedt%avg_vapor_ac @@ -471,10 +473,10 @@ subroutine lake_yscal(lake,dlakedt,htry,lakescal) real(kind=8) , intent(in) :: htry !------------------------------------------------------------------------------------! - lakescal%can_lntheta = abs(lake%can_lntheta) + abs(dlakedt%can_lntheta * htry) - lakescal%can_shv = abs(lake%can_shv ) + abs(dlakedt%can_shv * htry) - lakescal%can_co2 = abs(lake%can_co2 ) + abs(dlakedt%can_co2 * htry) - lakescal%lake_temp = abs(lake%lake_temp ) + abs(dlakedt%lake_temp * htry) + lakescal%can_enthalpy = abs(lake%can_enthalpy) + abs(dlakedt%can_enthalpy * htry) + lakescal%can_shv = abs(lake%can_shv ) + abs(dlakedt%can_shv * htry) + lakescal%can_co2 = abs(lake%can_co2 ) + abs(dlakedt%can_co2 * htry) + lakescal%lake_temp = abs(lake%lake_temp ) + abs(dlakedt%lake_temp * htry) return @@ -514,7 +516,7 @@ subroutine lake_errmax(errmax,lakescal,lakeerr) ! worst guess in the end. We only check prognostic variables. ! !------------------------------------------------------------------------------------! !----- 1. Log of potential temperature. ---------------------------------------------! - err = abs(lakeerr%can_lntheta / lakescal%can_lntheta) + err = abs(lakeerr%can_enthalpy / lakescal%can_enthalpy) errmax = max(errmax,err) !----- 2. Specific humidity. --------------------------------------------------------! err = abs(lakeerr%can_shv / lakescal%can_shv) diff --git a/BRAMS/src/ed2/mem_edcp.f90 b/BRAMS/src/ed2/mem_edcp.f90 index 439a61611..7ca2d3122 100644 --- a/BRAMS/src/ed2/mem_edcp.f90 +++ b/BRAMS/src/ed2/mem_edcp.f90 @@ -145,23 +145,23 @@ subroutine nullify_edflux(edflux) type(ed_flux), intent(inout) :: edflux !------------------------------------------------------------------------------------! - if (associated(edflux%ustar )) nullify(edflux%ustar ) - if (associated(edflux%tstar )) nullify(edflux%tstar ) - if (associated(edflux%rstar )) nullify(edflux%rstar ) - if (associated(edflux%cstar )) nullify(edflux%cstar ) - if (associated(edflux%zeta )) nullify(edflux%zeta ) - if (associated(edflux%ribulk )) nullify(edflux%ribulk ) - if (associated(edflux%sflux_u )) nullify(edflux%sflux_u ) - if (associated(edflux%sflux_v )) nullify(edflux%sflux_v ) - if (associated(edflux%sflux_r )) nullify(edflux%sflux_r ) - if (associated(edflux%sflux_t )) nullify(edflux%sflux_t ) - if (associated(edflux%sflux_c )) nullify(edflux%sflux_c ) - if (associated(edflux%sflux_w )) nullify(edflux%sflux_w ) - if (associated(edflux%rshort_gnd )) nullify(edflux%rshort_gnd ) - if (associated(edflux%rlong_gnd )) nullify(edflux%rlong_gnd ) - if (associated(edflux%albedt )) nullify(edflux%albedt ) - if (associated(edflux%rlongup )) nullify(edflux%rlongup ) - if (associated(edflux%rk4step )) nullify(edflux%rk4step ) + nullify(edflux%ustar ) + nullify(edflux%tstar ) + nullify(edflux%rstar ) + nullify(edflux%cstar ) + nullify(edflux%zeta ) + nullify(edflux%ribulk ) + nullify(edflux%sflux_u ) + nullify(edflux%sflux_v ) + nullify(edflux%sflux_r ) + nullify(edflux%sflux_t ) + nullify(edflux%sflux_c ) + nullify(edflux%sflux_w ) + nullify(edflux%rshort_gnd ) + nullify(edflux%rlong_gnd ) + nullify(edflux%albedt ) + nullify(edflux%rlongup ) + nullify(edflux%rk4step ) return end subroutine nullify_edflux @@ -340,8 +340,8 @@ subroutine nullify_edprecip(edprec) - if (associated(edprec%prev_aconpr )) nullify(edprec%prev_aconpr ) - if (associated(edprec%prev_abulkpr)) nullify(edprec%prev_abulkpr) + nullify(edprec%prev_aconpr ) + nullify(edprec%prev_abulkpr) return end subroutine nullify_edprecip diff --git a/BRAMS/src/fdda/mem_oda.f90 b/BRAMS/src/fdda/mem_oda.f90 index eb441efb5..15d3c4cd7 100644 --- a/BRAMS/src/fdda/mem_oda.f90 +++ b/BRAMS/src/fdda/mem_oda.f90 @@ -136,14 +136,14 @@ subroutine nullify_oda(oda) implicit none type (oda_vars) :: oda - if (associated(oda%uk)) nullify (oda%uk) - if (associated(oda%vk)) nullify (oda%vk) - if (associated(oda%tk)) nullify (oda%tk) - if (associated(oda%rk)) nullify (oda%rk) - if (associated(oda%ukv)) nullify (oda%ukv) - if (associated(oda%vkv)) nullify (oda%vkv) - if (associated(oda%tkv)) nullify (oda%tkv) - if (associated(oda%rkv)) nullify (oda%rkv) + nullify (oda%uk) + nullify (oda%vk) + nullify (oda%tk) + nullify (oda%rk) + nullify (oda%ukv) + nullify (oda%vkv) + nullify (oda%tkv) + nullify (oda%rkv) return end subroutine nullify_oda diff --git a/BRAMS/src/fdda/nud_analysis.f90 b/BRAMS/src/fdda/nud_analysis.f90 index af6dede43..b0286e1b1 100644 --- a/BRAMS/src/fdda/nud_analysis.f90 +++ b/BRAMS/src/fdda/nud_analysis.f90 @@ -390,7 +390,6 @@ subroutine varweight(n1,n2,n3,varwts,topt,rtgt) call abort_run('Incorrect specification of znudtop!','varweight','nud_analysis.f90') end if - do j=1,n3 do i=1,n2 diff --git a/BRAMS/src/fdda/oda_nudge.f90 b/BRAMS/src/fdda/oda_nudge.f90 index 78a3dc2c6..3455acd69 100644 --- a/BRAMS/src/fdda/oda_nudge.f90 +++ b/BRAMS/src/fdda/oda_nudge.f90 @@ -162,7 +162,10 @@ subroutine oda_nudge() ng=ngrid if (wt_oda_grid(ng) > 0.0 .and. time >= todabeg .and. time <= todaend) then - if(allocated(plt)) deallocate(plt);allocate(plt(nnxp(ng),nnyp(ng))) + if (allocated(plt)) then + deallocate(plt) + end if + allocate(plt(nnxp(ng),nnyp(ng))) call oda_tendency(mmzp(ng),mmxp(ng),mmyp(ng),mia(ng),miz(ng),mja(ng),mjz(ng) & ,basic_g(ng)%up,tend_g(ng)%ut,oda_g(ng)%uk,oda_g(ng)%ukv & diff --git a/BRAMS/src/fdda/oda_proc_obs.f90 b/BRAMS/src/fdda/oda_proc_obs.f90 index 55dd424ab..17bc9fd54 100644 --- a/BRAMS/src/fdda/oda_proc_obs.f90 +++ b/BRAMS/src/fdda/oda_proc_obs.f90 @@ -437,7 +437,7 @@ subroutine sfc_obs_convert(n1,n2,n3,pp,pi0,prs,ng,nobs) use mem_oda use rconstants - use therm_lib, only : rslif + use therm_lib, only : rslif, exner2press implicit none @@ -461,8 +461,7 @@ subroutine sfc_obs_convert(n1,n2,n3,pp,pi0,prs,ng,nobs) do j=1,n3 do i=1,n2 - prs(i,j)=( (pp(1,i,j)+pp(2,i,j)+pi0(1,i,j)+pi0(2,i,j))*.5 & - *cpi) ** cpor * p00 + prs(i,j)=exner2press((pp(1,i,j)+pp(2,i,j)+pi0(1,i,j)+pi0(2,i,j))*.5) enddo enddo diff --git a/BRAMS/src/fdda/read_ralph.f90 b/BRAMS/src/fdda/read_ralph.f90 index 4f8a0c3d6..cb7e7cf5e 100644 --- a/BRAMS/src/fdda/read_ralph.f90 +++ b/BRAMS/src/fdda/read_ralph.f90 @@ -557,7 +557,7 @@ subroutine sfc_data_convert (varn,cvars,nvars) if(rsfc_obs%t>-998. .and. rsfc_obs%td>-998. .and. & rsfc_obs%p>-998.) & varn(nv)=100.*min(1.,rehul(rsfc_obs%p,rsfc_obs%t+t00 & - ,rslf(rsfc_obs%p,rsfc_obs%td+t00))) + ,rslf(rsfc_obs%p,rsfc_obs%td+t00),.false.)) else print*,'UNKNOWN CONVERT VARIABLE in sfc_data_convert !!!!',cvar stop 'sfc_data_convert' @@ -624,18 +624,18 @@ subroutine upa_get_profile (varn,nlevels,cvar,ctype) if(rupa_obs%p(k)>-998.) varn(k)=rupa_obs%p(k) elseif(cvar(1:ll)=='pi') then ! Exner function - if(rupa_obs%p(k)>-998.) varn(k)=cp*(rupa_obs%p(k)*p00i)**rocp + if(rupa_obs%p(k)>-998.) varn(k)=cpdry*(rupa_obs%p(k)*p00i)**rocp elseif(cvar(1:ll)=='dewptc') then ! dewpoint in C if(rupa_obs%r(k)>-998..and.rupa_obs%t(k)>-998..and. & rupa_obs%p(k)>-998.) & - vv =ptrh2rvapl(rupa_obs%r(k),rupa_obs%p(k),rupa_obs%t(k)+t00) + vv =ptrh2rvapl(rupa_obs%r(k),rupa_obs%p(k),rupa_obs%t(k)+t00,.false.) varn(k)=dewpoint(rupa_obs%p(k),vv )-t00 elseif(cvar(1:ll)=='dewptf') then ! dewpoint in F if(rupa_obs%r(k)>-998..and.rupa_obs%t(k)>-998..and. & rupa_obs%p(k)>-998.) & - vv =ptrh2rvapl(rupa_obs%r(k),rupa_obs%p(k),rupa_obs%t(k)+t00) + vv =ptrh2rvapl(rupa_obs%r(k),rupa_obs%p(k),rupa_obs%t(k)+t00,.false.) varn(k)=(dewpoint(rupa_obs%p(k),vv )-t00)*1.8+32. elseif(cvar(1:ll)=='geo') then ! geopotential in m @@ -644,7 +644,7 @@ subroutine upa_get_profile (varn,nlevels,cvar,ctype) ! vapor in kg/kg if(rupa_obs%r(k)>-998..and.rupa_obs%t(k)>-998..and. & rupa_obs%p(k)>-998.) & - varn(k)= ptrh2rvapl(rupa_obs%r(k),rupa_obs%p(k),rupa_obs%t(k)+t00) + varn(k)= ptrh2rvapl(rupa_obs%r(k),rupa_obs%p(k),rupa_obs%t(k)+t00,.false.) elseif(cvar(1:ll)=='relhum') then ! rh in percent if(rupa_obs%r(k)>-998.) varn(k)=100. & diff --git a/BRAMS/src/fdda/varf_update.f90 b/BRAMS/src/fdda/varf_update.f90 index 80f2b1c8b..68c225f67 100644 --- a/BRAMS/src/fdda/varf_update.f90 +++ b/BRAMS/src/fdda/varf_update.f90 @@ -323,10 +323,12 @@ subroutine varref(n1,n2,n3,thp,pc,pi0,th0,rtp,co2p,dn0,dn0u,dn0v,uc,vc,topt,topu use ref_sounding use mem_scratch use rconstants - use therm_lib , only : virtt & ! intent(in) - , vapour_on ! ! intent(in) - use mem_basic , only : co2_on & ! intent(in) - , co2con ! ! intent(in) + use therm_lib , only : virtt & ! intent(in) + , exner2press & ! intent(in) + , extheta2temp & ! intent(in) + , vapour_on ! ! intent(in) + use mem_basic , only : co2_on & ! intent(in) + , co2con ! ! intent(in) implicit none !----- Arguments. ----------------------------------------------------------------------! @@ -429,8 +431,8 @@ subroutine varref(n1,n2,n3,thp,pc,pi0,th0,rtp,co2p,dn0,dn0u,dn0v,uc,vc,topt,topu !----- Finding the density. ------------------------------------------------------------! do k = 1,nzp - vctr4(k) = (pi01dn(k,ngrid) / cp) ** cpor * p00 - dn01dn(k,ngrid) = cp * vctr4(k) / (rdry * th01dn(k,ngrid) * pi01dn(k,ngrid)) + vctr4(k) = exner2press(pi01dn(k,ngrid)) + dn01dn(k,ngrid) = vctr4(k) / (rdry * extheta2temp(pi01dn(k,ngrid),th01dn(k,ngrid)) ) end do !------ Compute 3-D reference state from 1-D reference state. --------------------------! diff --git a/BRAMS/src/init/rdint.f90 b/BRAMS/src/init/rdint.f90 index 600b29427..cd443cf3f 100644 --- a/BRAMS/src/init/rdint.f90 +++ b/BRAMS/src/init/rdint.f90 @@ -34,6 +34,7 @@ subroutine initlz (name_name) use teb_spm_start , only : TEB_SPM ! ! intent(in) use mem_teb , only : teb_g ! ! intent(inout) use mem_teb_common , only : tebc_g ! ! intent(inout) + use mem_mnt_advec , only : iadvec ! ! intent(inout) use teb_vars_const , only : iteb ! ! intent(in) use mem_gaspart , only : gaspart_g ! ! intent(inout) use mem_emiss , only : ichemi & ! intent(inout) @@ -206,16 +207,19 @@ subroutine initlz (name_name) call thermo(nzp,nxp,nyp,1,nxp,1,nyp) if (level == 3) then - call azero3(nzp*nxp*nyp,scratch%vt3da,scratch%vt3dg,scratch%vt3dh) - call azero2(nzp*nxp*nyp,scratch%vt3dc,scratch%vt3di) + call azero(nzp*nxp*nyp,scratch%vt3da) + call azero(nzp*nxp*nyp,scratch%vt3dg) + call azero(nzp*nxp*nyp,scratch%vt3dh) + call azero(nzp*nxp*nyp,scratch%vt3dc) + call azero(nzp*nxp*nyp,scratch%vt3di) !----- Use scratch variables to define cccnp and cifnp ------------------------! call initqin(nzp,nxp,nyp,scratch%vt3da,scratch%vt3dg,scratch%vt3dh & ,basic_g(ifm)%pi0,basic_g(ifm)%pp,basic_g(ifm)%theta & ,basic_g(ifm)%dn0,scratch%vt3dc,scratch%vt3di ) !----- Copying them to the micro arrays if they are allocated -----------------! - if (irain >= 1) call atob(nzp*nxp*nyp,scratch%vt3da,micro_g(ifm)%rrp) - if (igraup >= 1) call atob(nzp*nxp*nyp,scratch%vt3dg,micro_g(ifm)%rgp) - if (ihail >= 1) call atob(nzp*nxp*nyp,scratch%vt3dh,micro_g(ifm)%rhp) + if (irain >= 1) call atob(nzp*nxp*nyp,scratch%vt3da,micro_g(ifm)%q2) + if (igraup >= 1) call atob(nzp*nxp*nyp,scratch%vt3dg,micro_g(ifm)%q6) + if (ihail >= 1) call atob(nzp*nxp*nyp,scratch%vt3dh,micro_g(ifm)%q7) if (icloud == 7) call atob(nzp*nxp*nyp,scratch%vt3dc,micro_g(ifm)%cccnp) if (ipris == 7) call atob(nzp*nxp*nyp,scratch%vt3di,micro_g(ifm)%cifnp) end if @@ -477,9 +481,21 @@ subroutine initlz (name_name) call negadj1(nzp,nxp,nyp,1,nxp,1,nyp) call thermo(nzp,nxp,nyp,1,nxp,1,nyp) if (level == 3) then - call initqin(nzp,nxp,nyp,micro_g(ifm)%q2,micro_g(ifm)%q6,micro_g(ifm)%q7 & + call azero(nzp*nxp*nyp,scratch%vt3da) + call azero(nzp*nxp*nyp,scratch%vt3dg) + call azero(nzp*nxp*nyp,scratch%vt3dh) + call azero(nzp*nxp*nyp,scratch%vt3dc) + call azero(nzp*nxp*nyp,scratch%vt3di) + !----- Use scratch variables to define cccnp and cifnp ---------------------! + call initqin(nzp,nxp,nyp,scratch%vt3da,scratch%vt3dg,scratch%vt3dh & ,basic_g(ifm)%pi0,basic_g(ifm)%pp,basic_g(ifm)%theta & - ,basic_g(ifm)%dn0,micro_g(ifm)%cccnp,micro_g(ifm)%cifnp) + ,basic_g(ifm)%dn0,scratch%vt3dc,scratch%vt3di ) + !----- Copying them to the micro arrays if they are allocated --------------! + if (irain >= 1) call atob(nzp*nxp*nyp,scratch%vt3da,micro_g(ifm)%q2) + if (igraup >= 1) call atob(nzp*nxp*nyp,scratch%vt3dg,micro_g(ifm)%q6) + if (ihail >= 1) call atob(nzp*nxp*nyp,scratch%vt3dh,micro_g(ifm)%q7) + if (icloud == 7) call atob(nzp*nxp*nyp,scratch%vt3dc,micro_g(ifm)%cccnp) + if (ipris == 7) call atob(nzp*nxp*nyp,scratch%vt3di,micro_g(ifm)%cifnp) end if !----- Heterogenous Soil Moisture Initialisation. -----------------------------! @@ -1050,6 +1066,7 @@ subroutine read_nl(filename) , bulk_on8 => bulk_on & ! intent(out) , level8 => level ! ! intent(out) use rconstants , only : vonk ! ! intent(in) + use mem_mnt_advec , only : iadvec ! ! intent(in) implicit none !----- Arguments. ----------------------------------------------------------------------! character(len=*) , intent(in) :: filename ! file name with namelists @@ -1111,18 +1128,18 @@ subroutine read_nl(filename) ,zkbmax,zcutdown,z_detr,max_heat,closure_type,maxens_lsf & ,maxens_eff,maxens_cap - namelist /MODEL_OPTIONS/ naddsc,icorflg,iexev,imassflx,ibnd,jbnd,cphas,lsflg,nfpt & - ,distim,iswrtyp,ilwrtyp,icumfdbk,radfrq,lonrad,npatch & - ,nvegpat,min_patch_area,isfcl,dtleaf,istar,igrndvap,ubmin & - ,ugbmin,ustmin,gamm,gamh,tprandtl,ribmax,leaf_maxwhc,ico2 & - ,co2con,nvgcon,pctlcon,nslcon,isoilcol,drtcon,zrough & - ,albedo,seatmp,dthcon,soil_moist,soil_moist_fail & - ,usdata_in,usmodel_in,slz,slmstr,stgoff,isoilbc,ipercol & - ,runoff_time,if_urban_canopy,idiffk,ibruvais,ibotflx & - ,ihorgrad,csx,csz,xkhkm,zkhkm,nna,nnb,nnc,akmin,akmax & - ,hgtmin,hgtmax,level,icloud,irain,ipris,isnow,iaggr & - ,igraup,ihail,cparm,rparm,pparm,sparm,aparm,gparm,hparm & - ,gnu + namelist /MODEL_OPTIONS/ naddsc,icorflg,iadvec,iexev,imassflx,ibnd,jbnd,cphas & + ,lsflg,nfpt,distim,iswrtyp,ilwrtyp,icumfdbk,radfrq,lonrad & + ,npatch,nvegpat,min_patch_area,isfcl,dtleaf,istar & + ,igrndvap,ubmin,ugbmin,ustmin,gamm,gamh,tprandtl,ribmax & + ,leaf_maxwhc,ico2,co2con,nvgcon,pctlcon,nslcon,isoilcol & + ,drtcon,zrough,albedo,seatmp,dthcon,soil_moist & + ,soil_moist_fail,usdata_in,usmodel_in,slz,slmstr,stgoff & + ,isoilbc,ipercol,runoff_time,if_urban_canopy,idiffk & + ,ibruvais,ibotflx,ihorgrad,csx,csz,xkhkm,zkhkm,nna,nnb & + ,nnc,akmin,akmax,hgtmin,hgtmax,level,icloud,irain,ipris & + ,isnow,iaggr,igraup,ihail,cparm,rparm,pparm,sparm,aparm & + ,gparm,hparm,gnu namelist /MODEL_SOUND/ ipsflg,itsflg,irtsflg,iusflg,hs,ps,ts,rts,us,vs,co2s @@ -1757,6 +1774,7 @@ subroutine read_nl(filename) write (unit=*,fmt='(a)') '' write (unit=*,fmt=*) ' naddsc =',naddsc write (unit=*,fmt=*) ' icorflg =',icorflg + write (unit=*,fmt=*) ' iadvec =',iadvec write (unit=*,fmt=*) ' iexev =',iexev write (unit=*,fmt=*) ' imassflx =',imassflx write (unit=*,fmt=*) ' ibnd =',ibnd diff --git a/BRAMS/src/init/rhhi.f90 b/BRAMS/src/init/rhhi.f90 index b6a51cd30..7fc902400 100644 --- a/BRAMS/src/init/rhhi.f90 +++ b/BRAMS/src/init/rhhi.f90 @@ -209,7 +209,7 @@ subroutine arrsnd(co2_on,co2con) case (2) !----- Potential temperature. ----------------------------------------! tavg = (vctr4(nsndg) + vctr4(nsndg-1)*p00k/ps(nsndg-1)**rocp) * .5 ps(nsndg) = (ps(nsndg-1)**rocp & - - grav * (zold2-zold1) * p00k/(cp*tavg)) ** cpor + - grav * (zold2-zold1) * p00k/(cpdry*tavg)) ** cpor end select end if case default @@ -246,7 +246,7 @@ subroutine arrsnd(co2_on,co2con) case (2) !----- Humidity given as mixing ratio in g/kg. -----------------------------! rts(nsndg) = rts(nsndg) * 1.e-3 case (3) !----- Humidity given as relative humidity in percent. ---------------------! - rts(nsndg) = ptrh2rvapl(rts(nsndg)*.01,ps(nsndg),ts(nsndg)) + rts(nsndg) = ptrh2rvapl(rts(nsndg)*.01,ps(nsndg),ts(nsndg),.false.) case (4) !----- Humidity given as dew point depression in Kelvin. -------------------! rts(nsndg) = rslf(ps(nsndg),ts(nsndg)-rts(nsndg)) case default @@ -323,8 +323,10 @@ subroutine refs1d(co2_on,co2con) use mem_scratch use ref_sounding use rconstants - use therm_lib , only : virtt & ! intent(in) - , vapour_on ! ! intent(in) + use therm_lib , only : virtt & ! function + , vapour_on & ! intent(in) + , exner2press & ! function + , extheta2temp ! ! function implicit none !----- Arguments. ----------------------------------------------------------------------! logical , intent(in) :: co2_on @@ -374,7 +376,7 @@ subroutine refs1d(co2_on,co2con) co201dn(1,ngrid) = co201dn(2,ngrid) !----- Finding the reference Exner function, using pressure and hydrostatic assumption. ! - pi01dn(1,ngrid) = cp * (ps(1) * p00i) ** rocp & + pi01dn(1,ngrid) = cpdry * (ps(1) * p00i) ** rocp & + grav * (hs(1) - ztn(1,ngrid)) & / (.5 * (th01dn(1,ngrid) + virtt(thds(1),rts(1)) ) ) do k = 2,nnzp(ngrid) @@ -384,8 +386,8 @@ subroutine refs1d(co2_on,co2con) !----- Finding the reference density. --------------------------------------------------! do k = 1,nnzp(ngrid) - vctr4(k) = (pi01dn(k,ngrid) / cp) ** cpor * p00 - dn01dn(k,ngrid) = cp * vctr4(k) / (rdry * th01dn(k,ngrid) * pi01dn(k,ngrid)) + vctr4(k) = exner2press(pi01dn(k,ngrid)) + dn01dn(k,ngrid) = vctr4(k) / (rdry * extheta2temp(pi01dn(k,ngrid),th01dn(k,ngrid))) end do return @@ -413,7 +415,9 @@ subroutine flds3d(n1,n2,n3,uc,vc,pi0,theta,thp,rtp,pc,rv,co2p,topt,topu,topv,rtg , theta_iceliq & ! function , tv2temp & ! function , vapour_on & ! intent(in) - , cloud_on ! ! intent(in) + , cloud_on & ! intent(in) + , exner2press & ! function + , extheta2temp ! ! function implicit none !----- Arguments. ----------------------------------------------------------------------! integer , intent(in) :: n1 @@ -527,8 +531,8 @@ subroutine flds3d(n1,n2,n3,uc,vc,pi0,theta,thp,rtp,pc,rv,co2p,topt,topu,topv,rtg !---------------------------------------------------------------------------------! if (cloud_on) then do k=1,nzp - p0(k) = (pi0(k,i,j)/cp)**cpor*p00 - temp(k) = pi0(k,i,j)*theta(k,i,j)/cp + p0(k) = exner2press(pi0(k,i,j)) + temp(k) = extheta2temp(pi0(k,i,j),theta(k,i,j)) rvls(k) = rslf(p0(k),temp(k)) rc(k) = max(0.,rtp(k,i,j)-rvls(k)) thp(k,i,j) = theta_iceliq(pi0(k,i,j),temp(k),rc(k),0.) @@ -567,6 +571,8 @@ subroutine flds3d_adap(n1,n2,n3,flpu,flpv,flpw,uc,vc,pi0,theta,thp,rtp,pc,rv,co2 use therm_lib , only : rslf & ! function , theta_iceliq & ! function , tv2temp & ! function + , exner2press & ! function + , extheta2temp & ! function , vapour_on & ! intent(in) , cloud_on ! ! intent(in) implicit none @@ -679,8 +685,8 @@ subroutine flds3d_adap(n1,n2,n3,flpu,flpv,flpw,uc,vc,pi0,theta,thp,rtp,pc,rv,co2 !---------------------------------------------------------------------------------! if (cloud_on) then do k = 1,n1 - p0(k) = (pi0(k,i,j)/cp) ** cpor * p00 - temp(k) = pi0(k,i,j) * theta(k,i,j) / cp + p0(k) = exner2press(pi0(k,i,j)) + temp(k) = extheta2temp(theta(k,i,j),pi0(k,i,j)) rvls(k) = rslf(p0(k),temp(k)) rc(k) = max(0.,rtp(k,i,j) - rvls(k)) thp(k,i,j) = theta_iceliq(pi0(k,i,j),temp(k),rc(k),0.) diff --git a/BRAMS/src/init/rinit.f90 b/BRAMS/src/init/rinit.f90 index 4b232ec3e..a30251a48 100644 --- a/BRAMS/src/init/rinit.f90 +++ b/BRAMS/src/init/rinit.f90 @@ -204,7 +204,7 @@ subroutine refs3d(n1,n2,n3,pi0,dn0,dn0u,dn0v,th0,topt,rtgt) endif c2 = 1. - cpor - c3 = cp ** c2 + c3 = cpdry ** c2 do k = n1-1,1,-1 pi0(k,i,j) = pi0(k+1,i,j) & + c1 / ((th0(k,i,j) + th0(k+1,i,j)) * dzm(k)) diff --git a/BRAMS/src/io/error_mess.f90 b/BRAMS/src/io/error_mess.f90 index ad17d1e53..61f188419 100644 --- a/BRAMS/src/io/error_mess.f90 +++ b/BRAMS/src/io/error_mess.f90 @@ -59,3 +59,64 @@ subroutine opspec_mess(reason,opssub) write (unit=*,fmt='(a)') ' ' return end subroutine opspec_mess +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +subroutine brams_fail_whale() + + implicit none + + write(unit=*,fmt='(a)') '' + write(unit=*,fmt='(a)') '' + write(unit=*,fmt='(a)') ':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' ___ _ _ ____ ____ ____ _ _ _ _ _ _ _ ____ _ ____ ' + write(unit=*,fmt='(a)') ' | |__| |___ |___ |__| | | | | | |__| |__| | |___ ' + write(unit=*,fmt='(a)') ' | | | |___ | | | | |___ |_|_| | | | | |___ |___ ' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' _ _ ____ ____ ____ ____ ____ ____ _ _ ____ ___ ' + write(unit=*,fmt='(a)') ' |__| |__| [__ | |__/ |__| [__ |__| |___ | \ ' + write(unit=*,fmt='(a)') ' | | | | ___] |___ | \ | | ___] | | |___ |__/ ' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' _ _ _ ___ ____ _ _ ____ _ _ ____ ____ _ _ _ ' + write(unit=*,fmt='(a)') ' | |\ | | | | \_/ | | | | |__/ [__ | |\/| ' + write(unit=*,fmt='(a)') ' | | \| | |__| | |__| |__| | \ ___] | | | ' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' .+shhhhhhhhhhyso/-` ' + write(unit=*,fmt='(a)') ' `.-::///+oooooooooooo+/:.` -hhhhhhhhhhhhhhhhhhhs+. ' + write(unit=*,fmt='(a)') ' -/oyhhhhhhhhhhhhhhhhhhhhhhhhhhhyo:` -hhhhhhhhhhhhhhhhhhhhhhy/ ' + write(unit=*,fmt='(a)') ' -ohhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhs:-oyhhhhhhhhhhhhhhhhhhhhhy- ' + write(unit=*,fmt='(a)') ' -yhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhy/ `-+yhhhhhhhhhhhhhhhhhhh+ ' + write(unit=*,fmt='(a)') ' +hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhy: :yhhhhhhhhhhhhhhhhhho ' + write(unit=*,fmt='(a)') ' ohhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhho` `yhhhhhhhhhhhhhhhhhh+ ' + write(unit=*,fmt='(a)') '/hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhy- .hhhhhhhhhhyshhhhhhh-' + write(unit=*,fmt='(a)') 'yhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhs` +hhhhhhhh: .hhhhhhs' + write(unit=*,fmt='(a)') 'hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh/`yhhhhhy. shhhhhh' + write(unit=*,fmt='(a)') 'hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh+/+o+: :hhhhhhh' + write(unit=*,fmt='(a)') 'hhhhhhhhhhhhhhh::yhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhso////+ohhhhhhhhs' + write(unit=*,fmt='(a)') 'yhhhhhhhhhhhhhh+/yhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh.' + write(unit=*,fmt='(a)') '/hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh: ' + write(unit=*,fmt='(a)') ' ohhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhs. ' + write(unit=*,fmt='(a)') ' /hhhhhhhhhhhoohhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhho- ' + write(unit=*,fmt='(a)') ' `:/+++/////shhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhsosyyyys+:. ' + write(unit=*,fmt='(a)') ' -hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh::+/ ' + write(unit=*,fmt='(a)') ' :/++++yhhhhhhhhhhs++oyhhhhhhhhhhs+++ohhhhhhs+/ohhhhhhhy: ' + write(unit=*,fmt='(a)') ' /shhhhhs+- `:+oso+/. .::- `:///-. ' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::' + + return +end subroutine brams_fail_whale +!==========================================================================================! +!==========================================================================================! diff --git a/BRAMS/src/io/inithis.f90 b/BRAMS/src/io/inithis.f90 index cbcf80850..286e16ae8 100644 --- a/BRAMS/src/io/inithis.f90 +++ b/BRAMS/src/io/inithis.f90 @@ -29,39 +29,83 @@ subroutine inithis() use ref_sounding use io_params use mem_scratch - use mem_aerad , only : nwave ! ! intent(in) - use grid_dims , only : maxgrds & ! intent(in) - , str_len ! ! intent(in) - use mem_cuparm, only : nclouds & ! intent(in) - , nnqparm ! ! intent(in) - use therm_lib , only : virtt & ! intent(in) - , vapour_on ! ! intent(in) + use mem_aerad , only : nwave ! ! intent(in) + use grid_dims , only : maxgrds & ! intent(in) + , str_len ! ! intent(in) + use mem_cuparm, only : nclouds & ! intent(in) + , nnqparm ! ! intent(in) + use therm_lib , only : virtt & ! intent(in) + , vapour_on & ! intent(in) + , exner2press & ! intent(in) + , extheta2temp ! ! intent(in) implicit none !----- Local variables -----------------------------------------------------------------! - character (len=str_len) :: hnamel, hnamelh - character (len=2) :: cng - integer :: ngrids1,ioutput1,nzg1,nzs1 - integer :: npatch1,nclouds1 - integer :: iyr,imn,idy,itm,ie,ngrmin - integer :: maxarr,maxarr2 - integer :: ngr,maxx1,maxy1,maxz1 - integer :: npts,nptsh,nv,nvh,i,k,nzpg1,nc - integer , save :: iunhd=11,inhunt=10 - integer , allocatable, dimension(:) :: nnxp1,nnyp1,nnzp1 - integer , allocatable, dimension(:) :: nnqparm1 - real :: ztop1 - real , allocatable, dimension(:) :: scr,scr2,scr3 - real , allocatable, dimension(:) :: platn1,plonn1 - real , allocatable, dimension(:) :: u01dn1,v01dn1,rt01dn1,th01dn1 - real , allocatable, dimension(:) :: pi01dn1,dn01dn1,co201dn1 - real , allocatable, dimension(:,:) :: xmn1,xtn1,ymn1,ytn1,zmn1,ztn1 - real , allocatable, dimension(:,:) :: topt1,parea - real(kind=8) :: time1 - type (head_table), allocatable, dimension(:) , save :: hr_table + character (len=str_len) :: hnamel + character (len=str_len) :: hnamelh + character (len=2) :: cng + integer :: ngrids1 + integer :: ioutput1 + integer :: nzg1 + integer :: nzs1 + integer :: npatch1 + integer :: nclouds1 + integer :: iyr + integer :: imn + integer :: idy + integer :: itm + integer :: ie + integer :: ngrmin + integer :: maxarr + integer :: maxarr2 + integer :: ngr + integer :: maxx1 + integer :: maxy1 + integer :: maxz1 + integer :: npts + integer :: nptsh + integer :: nv + integer :: nvh + integer :: i + integer :: k + integer :: nzpg1 + integer :: nc + real(kind=8) :: time1 + integer , allocatable, dimension(:) :: nnxp1 + integer , allocatable, dimension(:) :: nnyp1 + integer , allocatable, dimension(:) :: nnzp1 + integer , allocatable, dimension(:) :: nnqparm1 + real :: ztop1 + real , allocatable, dimension(:) :: scr + real , allocatable, dimension(:) :: scr2 + real , allocatable, dimension(:) :: scr3 + real , allocatable, dimension(:) :: platn1 + real , allocatable, dimension(:) :: plonn1 + real , allocatable, dimension(:) :: u01dn1 + real , allocatable, dimension(:) :: v01dn1 + real , allocatable, dimension(:) :: rt01dn1 + real , allocatable, dimension(:) :: th01dn1 + real , allocatable, dimension(:) :: pi01dn1 + real , allocatable, dimension(:) :: dn01dn1 + real , allocatable, dimension(:) :: co201dn1 + real , allocatable, dimension(:,:) :: xmn1 + real , allocatable, dimension(:,:) :: xtn1 + real , allocatable, dimension(:,:) :: ymn1 + real , allocatable, dimension(:,:) :: ytn1 + real , allocatable, dimension(:,:) :: zmn1 + real , allocatable, dimension(:,:) :: ztn1 + real , allocatable, dimension(:,:) :: topt1 + real , allocatable, dimension(:,:) :: parea + type (head_table), allocatable, dimension(:) :: hr_table + integer , save :: iunhd = 11 + integer , save :: inhunt = 10 !----- External functions --------------------------------------------------------------! - integer, external :: cio_i,cio_f,cio_i_sca,cio_f_sca,cio_f8_sca + integer , external :: cio_i + integer , external :: cio_f + integer , external :: cio_i_sca + integer , external :: cio_f_sca + integer , external :: cio_f8_sca !---------------------------------------------------------------------------------------! @@ -74,8 +118,12 @@ subroutine inithis() ie=cio_i_sca(iunhd,1,'ngrids',ngrids1,1) - allocate (nnxp1(ngrids1),nnyp1(ngrids1),nnzp1(ngrids1)) - allocate (platn1(ngrids1),plonn1(ngrids1),nnqparm1(ngrids1)) + allocate (nnxp1 (ngrids1)) + allocate (nnyp1 (ngrids1)) + allocate (nnzp1 (ngrids1)) + allocate (platn1 (ngrids1)) + allocate (plonn1 (ngrids1)) + allocate (nnqparm1(ngrids1)) ie=cio_i(iunhd,1,'nnxp',nnxp1,ngrids1) ie=cio_i(iunhd,1,'nnyp',nnyp1,ngrids1) @@ -138,13 +186,17 @@ subroutine inithis() maxx1=max(maxx1,nnxp1(ngr)) maxy1=max(maxy1,nnyp1(ngr)) maxz1=max(maxz1,nnzp1(ngr)) - enddo - - !---- Allocating variables based on the maximum dimensions -----------------------------! - allocate(xmn1(maxx1,ngrids1),xtn1(maxx1,ngrids1)) - allocate(ymn1(maxy1,ngrids1),ytn1(maxy1,ngrids1)) - allocate(zmn1(maxz1,ngrids1),ztn1(maxz1,ngrids1)) + end do + !---------------------------------------------------------------------------------------! + !---- Allocate variables based on the maximum dimensions -------------------------------! + allocate(xmn1(maxx1,ngrids1)) + allocate(xtn1(maxx1,ngrids1)) + allocate(ymn1(maxy1,ngrids1)) + allocate(ytn1(maxy1,ngrids1)) + allocate(zmn1(maxz1,ngrids1)) + allocate(ztn1(maxz1,ngrids1)) + !---------------------------------------------------------------------------------------! @@ -156,14 +208,14 @@ subroutine inithis() ie=cio_f(iunhd,1,'ytn'//cng,ytn1(:,ngr),nnyp1(ngr)) ie=cio_f(iunhd,1,'zmn'//cng,zmn1(:,ngr),nnzp1(ngr)) ie=cio_f(iunhd,1,'ztn'//cng,ztn1(:,ngr),nnzp1(ngr)) - enddo + end do allocate (topt1(maxarr2,ngrids1)) - allocate (parea(maxarr,ngrids1)) + allocate (parea(maxarr ,ngrids1)) - allocate (scr(maxarr)) - allocate (scr2(maxarr)) - allocate (scr3(maxarr)) + allocate (scr (maxarr)) + allocate (scr2 (maxarr)) + allocate (scr3 (maxarr)) call rams_f_open(inhunt,hnamel,'UNFORMATTED','OLD','READ',0) @@ -196,6 +248,7 @@ subroutine inithis() end do rewind(unit=inhunt) + !---------------------------------------------------------------------------------------! !----- Need wind rotation for the general case -----------------------------------------! @@ -329,20 +382,30 @@ subroutine inithis() ,1,vtab_r(nv,1)%var_p,nclouds,ngr,vtab_r(nv,1)%name,9) end if exit + !------------------------------------------------------------------------------! end if + !---------------------------------------------------------------------------------! end do - + !------------------------------------------------------------------------------------! end do + !---------------------------------------------------------------------------------------! - !----- Close the input history file and free some memory -------------------------------! + !----- Close the input history file. ---------------------------------------------------! close(unit=inhunt) - deallocate(scr,scr2,scr3,hr_table) + !---------------------------------------------------------------------------------------! + !----- Prepare 1D reference sounding --------------------------------------------------! nzpg1=nnzp1(1) - allocate(u01dn1(nzpg1), v01dn1(nzpg1),rt01dn1(nzpg1),th01dn1(nzpg1),pi01dn1(nzpg1) & - ,dn01dn1(nzpg1), co201dn1(nzpg1) ) + allocate(u01dn1 (nzpg1)) + allocate(v01dn1 (nzpg1)) + allocate(rt01dn1 (nzpg1)) + allocate(th01dn1 (nzpg1)) + allocate(pi01dn1 (nzpg1)) + allocate(dn01dn1 (nzpg1)) + allocate(co201dn1(nzpg1)) + !---------------------------------------------------------------------------------------! cng='01' ie=cio_f(iunhd,1,'u01dn'//cng , u01dn1,nnzp1(1)) @@ -358,24 +421,27 @@ subroutine inithis() call htint(nzpg1,u01dn1,ztn1(1,1) ,nnzp(1),u01dn(1,1),ztn(1,1)) call htint(nzpg1,v01dn1,ztn1(1,1) ,nnzp(1),v01dn(1,1),ztn(1,1)) - !----- Assing vapour mixing ratio only if the user is running a "wet" run --------------! + !----- Assign vapour mixing ratio only if the user is running a "wet" run --------------! if (vapour_on) then call htint(nzpg1,rt01dn1,ztn1(1,1),nnzp(1),rt01dn(1,1),ztn(1,1)) else rt01dn(1:nnzp(ngrid),1) = 0. end if + !---------------------------------------------------------------------------------------! - !----- Assing CO2 mixing ratio only if the user is running a CO2 run -------------------! + !----- Assign CO2 mixing ratio only if the user is running a CO2 run -------------------! if (co2_on) then call htint(nzpg1,co201dn1,ztn1(1,1),nnzp(1),co201dn(1,1),ztn(1,1)) else co201dn(1:nnzp(ngrid),1) = co2con(1) - endif + end if + !---------------------------------------------------------------------------------------! - !----- Saving the virtual potential temperature ----------------------------------------! + !----- Save the virtual potential temperature ------------------------------------------! do k = 1,nnzp(ngrid) th01dn(k,1) = virtt(vctr1(k),rt01dn(k,1)) end do + !---------------------------------------------------------------------------------------! !----- Lowest level: same as the one just above ----------------------------------------! u01dn(1,1) = u01dn(2,1) @@ -384,18 +450,23 @@ subroutine inithis() th01dn(1,1) = th01dn(2,1) pi01dn(1,1) = pi01dn1(1) + grav * (ztn1(1,1)-ztn(1,1)) & / (.5 * (th01dn(1,1) + virtt(th01dn1(1),rt01dn1(1)) ) ) + !---------------------------------------------------------------------------------------! + - !----- Computing the ref. Exner function profile, based on hydrostatic equilibrium -----! + !----- Compute the ref. Exner function profile, based on hydrostatic equilibrium. ------! do k = 2,nnzp(1) pi01dn(k,1) = pi01dn(k-1,1) - grav & / (dzmn(k-1,1)* .5 * (th01dn(k,1) + th01dn(k-1,1))) end do + !---------------------------------------------------------------------------------------! - !----- Computing the ref. density profile, based on the perfect gas law ----------------! + + !----- Find the ref. density profile, based on the perfect gas law. --------------------! do k = 1,nnzp(1) - vctr4(k) = (pi01dn(k,1) / cp) ** cpor * p00 - dn01dn(k,1) = cp * vctr4(k) / (rdry * th01dn(k,1) * pi01dn(k,1)) + vctr4(k) = exner2press(pi01dn(k,1)) + dn01dn(k,1) = vctr4(k) / (rdry * extheta2temp(pi01dn(k,1),th01dn(k,1)) ) end do + !---------------------------------------------------------------------------------------! close(unit=iunhd,status='keep') @@ -405,6 +476,37 @@ subroutine inithis() , basic_g(1)%dn0u ,basic_g(1)%dn0v & , basic_g(1)%th0 ,grid_g(1)%topt & , grid_g(1)%rtgt ) + !---------------------------------------------------------------------------------------! + + + + !----- Free memory of all allocatable variables. ---------------------------------------! + deallocate(nnxp1 ) + deallocate(nnyp1 ) + deallocate(nnzp1 ) + deallocate(nnqparm1 ) + deallocate(scr ) + deallocate(scr2 ) + deallocate(scr3 ) + deallocate(platn1 ) + deallocate(plonn1 ) + deallocate(u01dn1 ) + deallocate(v01dn1 ) + deallocate(rt01dn1 ) + deallocate(th01dn1 ) + deallocate(pi01dn1 ) + deallocate(dn01dn1 ) + deallocate(co201dn1 ) + deallocate(xmn1 ) + deallocate(xtn1 ) + deallocate(ymn1 ) + deallocate(ytn1 ) + deallocate(zmn1 ) + deallocate(ztn1 ) + deallocate(topt1 ) + deallocate(parea ) + deallocate(hr_table ) + !---------------------------------------------------------------------------------------! return end subroutine inithis diff --git a/BRAMS/src/io/opspec.f90 b/BRAMS/src/io/opspec.f90 index b71507622..313d24c60 100644 --- a/BRAMS/src/io/opspec.f90 +++ b/BRAMS/src/io/opspec.f90 @@ -627,6 +627,7 @@ subroutine opspec3 use mem_basic, only : ico2, co2con + use mem_mnt_advec, only : iadvec implicit none integer :: ip,k,ifaterr,iwarerr,infoerr,ng,ngr,nc,nzz @@ -1048,9 +1049,21 @@ subroutine opspec3 ifaterr = ifaterr +1 end if + if (iadvec < 1 .or. iadvec > 2) then + print *, 'FATAL - IADVEC must be either 1 or 2.' + ifaterr=ifaterr+1 + else if (iadvec == 2 .and. if_adap /= 0) then + print *, 'FATAL - Monotonic advection is only allowed with sigma-z coordinates...' + print *, ' Either set iadvec to 1 or if_adap to 0!' + ifaterr=ifaterr+1 + end if + ![MLO - Some extra checks for mass and Medvidy's fix on Exner tendency ! Complete Exner tendency and vertical coordinate. - if (iexev == 2 .and. if_adap /= 0) then + if (iexev < 1 .or. iexev > 2) then + print *, 'FATAL - IEXEV must be either 1 or 2.' + ifaterr=ifaterr+1 + elseif (iexev == 2 .and. if_adap /= 0) then print *, 'FATAL - IEXEV cannot be set to 2 with adaptive coordinate' ifaterr=ifaterr+1 end if diff --git a/BRAMS/src/io/rcio.f90 b/BRAMS/src/io/rcio.f90 index 3a1573824..1d7c23b8d 100644 --- a/BRAMS/src/io/rcio.f90 +++ b/BRAMS/src/io/rcio.f90 @@ -9,48 +9,62 @@ subroutine commio (cfile,io,iun) use mem_all - use therm_lib, only: level - use mem_mass, only: imassflx, iexev - use leaf_coms, only : ubmin & ! intent(inout) - , ugbmin & ! intent(inout) - , ustmin & ! intent(inout) - , leaf_gamm => gamm & ! intent(inout) - , leaf_gamh => gamh & ! intent(inout) - , tprandtl & ! intent(inout) - , ribmax & ! intent(inout) - , leaf_maxwhc & ! intent(inout) - , min_patch_area & ! intent(inout) - , kroot & ! intent(inout) - , nvtyp & ! intent(inout) - , nvtyp_teb & ! intent(inout) - , nstyp & ! intent(inout) - , slden & ! intent(inout) - , slcpd & ! intent(inout) - , slbs & ! intent(inout) - , slcond & ! intent(inout) - , slcons & ! intent(inout) - , slmsts & ! intent(inout) - , slpots & ! intent(inout) - , ssand & ! intent(inout) - , sclay & ! intent(inout) - , sorgan & ! intent(inout) - , sporo & ! intent(inout) - , soilwp & ! intent(inout) - , soilcp & ! intent(inout) - , slfc & ! intent(inout) - , emisg & ! intent(inout) - , emisv & ! intent(inout) - , root & ! intent(inout) - , cmin & ! intent(inout) - , corg & ! intent(inout) - , cwat & ! intent(inout) - , cair & ! intent(inout) - , cka & ! intent(inout) - , ckw ! ! intent(inout) - use grell_coms, only : iupmethod,radius,depth_min,cap_maxs,cld2prec & - ,zkbmax,zcutdown,z_detr,max_heat,closure_type & - ,maxens_lsf,maxens_eff,maxens_cap - use turb_coms, only : nna, nnb, nnc + use therm_lib , only : level ! ! intent(inout) + use mem_mass , only : imassflx & ! intent(inout) + , iexev ! ! intent(inout) + use mem_mnt_advec, only : iadvec ! ! intent(inout) + use leaf_coms , only : ubmin & ! intent(inout) + , ugbmin & ! intent(inout) + , ustmin & ! intent(inout) + , leaf_gamm => gamm & ! intent(inout) + , leaf_gamh => gamh & ! intent(inout) + , tprandtl & ! intent(inout) + , ribmax & ! intent(inout) + , leaf_maxwhc & ! intent(inout) + , min_patch_area & ! intent(inout) + , kroot & ! intent(inout) + , nvtyp & ! intent(inout) + , nvtyp_teb & ! intent(inout) + , nstyp & ! intent(inout) + , slden & ! intent(inout) + , slcpd & ! intent(inout) + , slbs & ! intent(inout) + , slcond & ! intent(inout) + , slcons & ! intent(inout) + , slmsts & ! intent(inout) + , slpots & ! intent(inout) + , ssand & ! intent(inout) + , sclay & ! intent(inout) + , sorgan & ! intent(inout) + , sporo & ! intent(inout) + , soilwp & ! intent(inout) + , soilcp & ! intent(inout) + , slfc & ! intent(inout) + , emisg & ! intent(inout) + , emisv & ! intent(inout) + , root & ! intent(inout) + , cmin & ! intent(inout) + , corg & ! intent(inout) + , cwat & ! intent(inout) + , cair & ! intent(inout) + , cka & ! intent(inout) + , ckw ! ! intent(inout) + use grell_coms , only : iupmethod & ! intent(inout) + , radius & ! intent(inout) + , depth_min & ! intent(inout) + , cap_maxs & ! intent(inout) + , cld2prec & ! intent(inout) + , zkbmax & ! intent(inout) + , zcutdown & ! intent(inout) + , z_detr & ! intent(inout) + , max_heat & ! intent(inout) + , closure_type & ! intent(inout) + , maxens_lsf & ! intent(inout) + , maxens_eff & ! intent(inout) + , maxens_cap ! ! intent(inout) + use turb_coms , only : nna & ! intent(inout) + , nnb & ! intent(inout) + , nnc ! ! intent(inout) implicit none integer :: iun character(len=*) :: io,cfile @@ -181,6 +195,7 @@ subroutine commio (cfile,io,iun) ie=cio_i_sca(iun,irw,'jbnd',jbnd,1) ie=cio_i_sca(iun,irw,'icorflg',icorflg,1) ![MLO + ie=cio_i_sca(iun,irw,'iadvec',iadvec,1) ie=cio_i_sca(iun,irw,'iexev',iexev,1) ie=cio_i_sca(iun,irw,'imassflx',imassflx,1) !MLO] diff --git a/BRAMS/src/io/rio.f90 b/BRAMS/src/io/rio.f90 index c03f77676..de3f83254 100644 --- a/BRAMS/src/io/rio.f90 +++ b/BRAMS/src/io/rio.f90 @@ -138,14 +138,15 @@ subroutine hist_read(maxarr,hnamein,iunhd) integer :: ngr,npts,nptsh,nv,nvh,i character(len=10) :: post real , allocatable, dimension(:) :: scr - type (head_table), allocatable , save :: hr_table(:) + type (head_table), allocatable, dimension(:) :: hr_table !----- Local constants -----------------------------------------------------------------! integer , parameter :: inhunt=10 !---------------------------------------------------------------------------------------! - !----- Allocating scratch array --------------------------------------------------------! + !----- Allocate a scratch array. -------------------------------------------------------! allocate (scr(maxarr)) + !---------------------------------------------------------------------------------------! !----- Read variable header information ------------------------------------------------! rewind(unit= iunhd) @@ -156,20 +157,24 @@ subroutine hist_read(maxarr,hnamein,iunhd) ,hr_table(nv)%idim_type,hr_table(nv)%ngrid & ,hr_table(nv)%nvalues end do + !---------------------------------------------------------------------------------------! !----- Open history data file ----------------------------------------------------------! call rams_f_open(inhunt,hnamein,'UNFORMATTED','OLD','READ',0) + !---------------------------------------------------------------------------------------! !----- Loop through all variables ------------------------------------------------------! do nvh=1,nvbtab !----- Read a variable --------------------------------------------------------------! nptsh = hr_table(nvh)%nvalues read(unit=inhunt) (scr(i),i=1,nptsh) + !------------------------------------------------------------------------------------! !----- See if this variable is active in the current run ----------------------------! ngr = hr_table(nvh)%ngrid if(ngr > nvgrids) cycle + !------------------------------------------------------------------------------------! do nv = 1,num_var(ngr) npts=vtab_r(nv,ngr)%npts @@ -185,13 +190,17 @@ subroutine hist_read(maxarr,hnamein,iunhd) call atob(npts,scr(1),vtab_r(nv,ngr)%var_p) exit end if + !---------------------------------------------------------------------------------! end do - + !------------------------------------------------------------------------------------! end do + !---------------------------------------------------------------------------------------! - !----- Close the input history file then freeing some memory ---------------------------! + !----- Close the input history file then free some memory. -----------------------------! close(unit=inhunt,status='keep') - deallocate(scr,hr_table) + deallocate(scr) + deallocate(hr_table) + !---------------------------------------------------------------------------------------! return end subroutine hist_read @@ -223,20 +232,29 @@ subroutine hiswrt(restart) !----- Arguments -----------------------------------------------------------------------! character (len=*) , intent(in) :: restart !----- Local variables -----------------------------------------------------------------! - character(len=10) :: c0, c1 - character(len=str_len) , save :: hnameold,hnameoldh - character(len=str_len) :: hnamel,hnamelh + character(len=10) :: c0 + character(len=10) :: c1 + character(len=str_len) , save :: hnameold + character(len=str_len) , save :: hnameoldh + character(len=str_len) :: hnamel + character(len=str_len) :: hnamelh logical :: hereitis - integer :: nv,nwordh,ngr,nvcnt - integer , save :: iohunt=10, ncall=0 - integer , save :: ncall_head=0,nvtoth=0 + integer :: nv + integer :: nwordh + integer :: ngr + integer :: nvcnt + !----- Locally saved variables. --------------------------------------------------------! + integer , save :: iohunt= 10 + logical , save :: first_call = .true. + logical , save :: first_call_head = .true. + integer , save :: nvtoth = 0 type (head_table), dimension(:), allocatable, save :: hw_table !----- Local constants -----------------------------------------------------------------! !---------------------------------------------------------------------------------------! if (ioutput == 0) return - if (ncall_head == 0) then + if (first_call_head) then !----- Find total number of fields to be written -----------------------------------! do ngr=1,ngrids do nv = 1,num_var(ngr) @@ -244,7 +262,7 @@ subroutine hiswrt(restart) end do end do allocate (hw_table(nvtoth)) - ncall_head=1 + first_call_head = .false. end if !----- Open a new output file. ---------------------------------------------------------! @@ -300,11 +318,11 @@ subroutine hiswrt(restart) !----- DO NOT remove the old history file if doing a restart or if IFLAG is set. -------! if (ihistdel == 1) then - if (ncall == 0) then + if (first_call) then hnameold = hnamel hnameoldh = hnamelh end if - if (ncall == 1 .and. iflag == 0) then + if ((.not. first_call) .and. iflag == 0) then inquire (file=trim(hnameold),exist=hereitis) !----- This is to avoid system calls that cause infiniband to crash --------------! if (hereitis) then @@ -319,8 +337,10 @@ subroutine hiswrt(restart) hnameold = hnamel hnameoldh = hnamelh end if - ncall = 1 - endif + first_call = .false. + !------------------------------------------------------------------------------------! + end if + !---------------------------------------------------------------------------------------! return end subroutine hiswrt diff --git a/BRAMS/src/io/rname.f90 b/BRAMS/src/io/rname.f90 index 5e85dd9d7..a43335c4e 100644 --- a/BRAMS/src/io/rname.f90 +++ b/BRAMS/src/io/rname.f90 @@ -16,6 +16,7 @@ subroutine NAMEOUT use mem_all use therm_lib, only: level use mem_mass, only : iexev, imassflx + use mem_mnt_advec, only : iadvec use grell_coms, only: & closure_type, & ! INTENT(IN) maxclouds, & ! INTENT(IN) @@ -122,7 +123,7 @@ subroutine NAMEOUT ![MLO - Adding ED2 and mass variables: ! mass: - write(6,298) IEXEV,IMASSFLX,IBRUVAIS,IBOTFLX + write(6,298) IADVEC,IEXEV,IMASSFLX,IBRUVAIS,IBOTFLX ! ED2: write(6,205)LONRAD,IMONTHA,IDATEA,IYEARA,ITIMEA write(6,297) ISFCL,ISTAR,IGRNDVAP @@ -146,8 +147,9 @@ subroutine NAMEOUT 205 format(' LONRAD=',I4,' IMONTHA=',I4,' IDATEA=',I4 & ,' IYEARA=',I4,' ITIMEA=',I4) 297 format(' ISFCL=',I4,' ISTAR=',I4,' IGRNDVAP=',I4) -298 format(' IEXEV=',I4,' IMASSFLX=',I4,' IBRUVAIS=',I4,' IBOTFLX=',I4) -299 format(' IMONTHZ=',I4,' IDATEZ=',I4 & +298 format(' IADVEC=',I4,' IEXEV=',I4,' IMASSFLX=',I4 & + ,' IBRUVAIS=',I4,' IBOTFLX=',I4) +299 format(' IMONTHZ=',I4,' IDATEZ=',I4 & ,' IYEARZ=',I4,' ITIMEZ=',I4) 206 format(' NVGCON=',I4,' NPLT=',I4,' IPSFLG=',I4 & diff --git a/BRAMS/src/io/rprnt.f90 b/BRAMS/src/io/rprnt.f90 index 2ca82c002..956db7662 100644 --- a/BRAMS/src/io/rprnt.f90 +++ b/BRAMS/src/io/rprnt.f90 @@ -190,7 +190,7 @@ subroutine sfcprt(n2,n3,mzg,mzs,npat,leaf,vnam,lprt) use mem_leaf use leaf_coms use rconstants, only: wdns -use therm_lib, only: qtk, qwtk +use therm_lib, only: uint2tl, uextcm2tl type (leaf_vars) :: leaf dimension tempkk(20),fracliqq(20),area(20) @@ -338,13 +338,13 @@ subroutine sfcprt(n2,n3,mzg,mzs,npat,leaf,vnam,lprt) do i = i1,i2 if (ipat == 1 .and. k == mzg) then - call qtk(leaf%soil_energy(k,i,j,ipat) & + call uint2tl(leaf%soil_energy(k,i,j,ipat) & ,tempkk(i+1-i1),fracliqq(i+1-i1)) elseif (ipat == 1) then soil_tempk(i+1-i1) = leaf%soil_energy(k,i,j,ipat) else nsoil = nint(leaf%soil_text(k,i,j,ipat)) - call qwtk(leaf%soil_energy(k,i,j,ipat) & + call uextcm2tl(leaf%soil_energy(k,i,j,ipat) & ,leaf%soil_water (k,i,j,ipat)*wdns & ,slcpd(nsoil),tempkk(i+1-i1),fracliqq(i+1-i1)) endif @@ -368,7 +368,7 @@ subroutine sfcprt(n2,n3,mzg,mzs,npat,leaf,vnam,lprt) elseif (vnam == 'sfcwater_temp' ) then do i = i1,i2 nsoil = nint(leaf%soil_text(k,i,j,ipat)) - call qwtk(leaf%soil_energy(k,i,j,ipat) & + call uextcm2tl(leaf%soil_energy(k,i,j,ipat) & ,leaf%soil_water (k,i,j,ipat)*wdns & ,slcpd(nsoil),tempkk(i+1-i1),fracliqq(i+1-i1)) enddo @@ -592,7 +592,14 @@ FUNCTION OPTLIB(VARN,K,I,J,IPLGRD,FMT,TILO) use mem_all use var_tables use rconstants -use therm_lib, only: rehul,rehui,rehuil,virtt +use therm_lib, only : rehul & ! intent(in) + , rehui & ! intent(in) + , rehuil & ! intent(in) + , virtt & ! intent(in) + , exner2press & ! intent(in) + , press2exner & ! intent(in) + , extheta2temp & ! intent(in) + , extemp2theta ! ! intent(in) CHARACTER*(*) VARN CHARACTER*8 FMT,TILO ! @@ -847,7 +854,7 @@ FUNCTION OPTLIB(VARN,K,I,J,IPLGRD,FMT,TILO) VALTHET = basic_g(ngrid)%THETA(k,i,j) VALPP = basic_g(ngrid)%PP(k,i,j) VALPI0 = basic_g(ngrid)%PI0(k,i,j) - OPTLIB = VALTHET*(VALPP+VALPI0)/CP + OPTLIB = VALTHET*(VALPP+VALPI0)/CPDRY ENDIF ! ! TEMPERATURE @@ -860,7 +867,7 @@ FUNCTION OPTLIB(VARN,K,I,J,IPLGRD,FMT,TILO) VALTHET = basic_g(ngrid)%THETA(k,i,j) VALPP = basic_g(ngrid)%PP(k,i,j) VALPI0 = basic_g(ngrid)%PI0(k,i,j) - OPTLIB = VALTHET*(VALPP+VALPI0)/CP - t00 + OPTLIB = VALTHET*(VALPP+VALPI0)/CPDRY - t00 ENDIF ! ! VIRTUAL TEMPERATURE @@ -877,7 +884,7 @@ FUNCTION OPTLIB(VARN,K,I,J,IPLGRD,FMT,TILO) VALRV = 0 IF (LEVEL.GE.1) VALRV = basic_g(ngrid)%RV(k,i,j) OPTLIB = virtt(VALTHET,VALRV,VALRTP) & - *(VALPP + VALPI0)/CP + *(VALPP + VALPI0)/CPDRY ENDIF ! ! VIRTUAL TEMPERATURE PERTURBATION @@ -895,7 +902,7 @@ FUNCTION OPTLIB(VARN,K,I,J,IPLGRD,FMT,TILO) VALRV = 0 IF (LEVEL.GE.1) VALRV = basic_g(ngrid)%RV(k,i,j) OPTLIB = (virtt(VALTHET,VALRV,VALRTP) -VALTHV0) & - *(VALPP + VALPI0)/CP + *(VALPP + VALPI0)/CPDRY ENDIF ! ! TOTAL WATER MIXING RATIO @@ -1198,10 +1205,10 @@ FUNCTION OPTLIB(VARN,K,I,J,IPLGRD,FMT,TILO) VALTHET= basic_g(ngrid)%THETA(k,i,j) VALPP = basic_g(ngrid)%PP(k,i,j) VALPI0 = basic_g(ngrid)%PI0(k,i,j) - VALTEMP= VALTHET*(VALPP+VALPI0)/CP - VALPRS = ((VALPI0 + VALPP)/CP)**CPOR * P00 + VALTEMP= extheta2temp(VALPP+VALPI0,VALTHET) + VALPRS = exner2press(VALPI0 + VALPP) VALRV = basic_g(ngrid)%RV(k,i,j) - OPTLIB = 100.*REHUL(VALPRS,VALTEMP,VALRV) + OPTLIB = 100.*REHUL(VALPRS,VALTEMP,VALRV,.false.) IF(OPTLIB > 100.)THEN OPTLIB=OPTLIB-100. ELSE @@ -1219,10 +1226,10 @@ FUNCTION OPTLIB(VARN,K,I,J,IPLGRD,FMT,TILO) VALTHET= basic_g(ngrid)%THETA(k,i,j) VALPP = basic_g(ngrid)%PP(k,i,j) VALPI0 = basic_g(ngrid)%PI0(k,i,j) - VALTEMP= VALTHET*(VALPP+VALPI0)/CP - VALPRS = ((VALPI0 + VALPP)/CP)**CPOR * P00 + VALTEMP= extheta2temp(VALPP+VALPI0,VALTHET) + VALPRS = exner2press(VALPI0 + VALPP) VALRV = basic_g(ngrid)%RV(k,i,j) - OPTLIB = 100.*REHUI(VALPRS,VALTEMP,VALRV) + OPTLIB = 100.*REHUI(VALPRS,VALTEMP,VALRV,.false.) IF(OPTLIB > 100.)THEN OPTLIB=OPTLIB-100. ELSE @@ -1240,10 +1247,10 @@ FUNCTION OPTLIB(VARN,K,I,J,IPLGRD,FMT,TILO) VALTHET= basic_g(ngrid)%THETA(k,i,j) VALPP = basic_g(ngrid)%PP(k,i,j) VALPI0 = basic_g(ngrid)%PI0(k,i,j) - VALTEMP= VALTHET*(VALPP+VALPI0)/CP - VALPRS = ((VALPI0 + VALPP)/CP)**CPOR * P00 + VALTEMP= extheta2temp(VALPP+VALPI0,VALTHET) + VALPRS = exner2press(VALPI0 + VALPP) VALRV = basic_g(ngrid)%RV(k,i,j) - OPTLIB = 100. * rehuil(VALPRS,VALTEMP,VALRV) + OPTLIB = 100. * rehuil(VALPRS,VALTEMP,VALRV,.false.) ENDIF ! ! TOTAL NUMBER CONCENTRATION OF CCN @@ -1737,11 +1744,11 @@ SUBROUTINE PRTOPT(M) use rconstants use mem_turb use ref_sounding -use therm_lib, only: rehuil,tv2temp +use therm_lib, only: rehuil,tv2temp,exner2press IF(INITIAL.NE.2)THEN do k=1,nsndg - vctr1(k) = 100. *rehuil(ps(k),ts(k),rts(k)) + vctr1(k) = 100. *rehuil(ps(k),ts(k),rts(k),.false.) end do WRITE(M,41) 41 FORMAT(/,'------------------------------SOUNDING INPUT-------' & @@ -1755,7 +1762,7 @@ SUBROUTINE PRTOPT(M) ENDIF ! DO K=1,NNZP(1) - VCTR1(K)=P00*(PI01DN(K,1)/CP)**CPOR + VCTR1(K)=exner2press(PI01DN(K,1)) VCTR2(K)=tv2temp(TH01DN(K,1),RT01DN(K,1)) ENDDO WRITE(M,310)IREF,JREF,TOPREF,(ZTN(K,1),U01DN(K,1),V01DN(K,1) & diff --git a/BRAMS/src/isan/aobj.f90 b/BRAMS/src/isan/aobj.f90 index 13551359d..ac72f2881 100644 --- a/BRAMS/src/isan/aobj.f90 +++ b/BRAMS/src/isan/aobj.f90 @@ -21,7 +21,6 @@ subroutine obj_anal (ctype,ng,nxp,nyp,g_lat,g_lon & integer, save :: nvar=1 -real, allocatable :: pscr(:,:) if (ctype == 'isen') then @@ -53,18 +52,11 @@ subroutine obj_anal (ctype,ng,nxp,nyp,g_lat,g_lon & elseif (ctype == 'sigz') then -!allocate(pscr(nxp,nyp)) -!pscr(1:nxp,1:nyp)=ps_u(1:nxp,1:nyp,2) -!call ezcntr(pscr,nxp,nyp) call obanl (nxp,nyp,nsigz,nvar, ps_u, g_lat, g_lon & ,nsta,nsta, ups_u,up_lat,up_lon & ,nxp,nyp, ps_u, g_lat, g_lon & ,igridfl,wvlnth(ng),respon(ng),gobsep,gobrad,gridwt(ng) & ,polelat,polelon,swx,swy,delx,dely) -!pscr(1:nxp,1:nyp)=ps_u(1:nxp,1:nyp,20) -!call ezcntr(pscr,nxp,nyp) -!call clsgks -!stop call obanl (nxp,nyp,nsigz,nvar, ps_v, g_lat, g_lon & ,nsta,nsta, ups_v,up_lat,up_lon & ,nxp,nyp, ps_v, g_lat, g_lon & diff --git a/BRAMS/src/isan/asti.f90 b/BRAMS/src/isan/asti.f90 index 9727f424c..71165b93d 100644 --- a/BRAMS/src/isan/asti.f90 +++ b/BRAMS/src/isan/asti.f90 @@ -524,7 +524,7 @@ subroutine strmfun (nxp,nyp,topt,rtgt) do k=lbc+1,nisn pi_s(i,j,k)=1e30 if(pi_p(i,j,k).lt.1e19) then - pi_s(i,j,k)=syo+cp*(po**rocp+pi_p(i,j,k)**rocp) & + pi_s(i,j,k)=syo+cpdry*(po**rocp+pi_p(i,j,k)**rocp) & *.5/p00**rocp *(levth(k)-tho) syo=pi_s(i,j,k) po=pi_p(i,j,k) @@ -541,7 +541,7 @@ subroutine strmfun (nxp,nyp,topt,rtgt) do k=lbc-1,1,-1 pi_s(i,j,k)=1e30 if(pi_p(i,j,k).lt.1e19) then - pi_s(i,j,k)=syo+cp*(po**rocp+pi_p(i,j,k)**rocp) & + pi_s(i,j,k)=syo+cpdry*(po**rocp+pi_p(i,j,k)**rocp) & *.5/p00**rocp*(levth(k)-tho) syo=pi_s(i,j,k) po=pi_p(i,j,k) @@ -584,11 +584,11 @@ subroutine strmfun (nxp,nyp,topt,rtgt) do k=1,nsigz temp(k)=ps_t(i,j,k)*(ps_p(i,j,k)/p00)**rocp sigzr(k)=topt(i,j)+sigz(k)*rtgt(i,j) - raux = ptrh2rvapil(ps_r(i,j,k),ps_p(i,j,k),temp(k)) + raux = ptrh2rvapil(ps_r(i,j,k),ps_p(i,j,k),temp(k),.false.) thv(k)=virtt(ps_t(i,j,k),raux) enddo - ps_p(i,j,lbcp)=cp*(ps_p(i,j,lbcp)/p00)**rocp + ps_p(i,j,lbcp)=cpdry*(ps_p(i,j,lbcp)/p00)**rocp thvo=thv(lbcp) po=ps_p(i,j,lbcp) @@ -617,7 +617,7 @@ subroutine strmfun (nxp,nyp,topt,rtgt) enddo do k=1,nsigz - ps_p(i,j,k)=(ps_p(i,j,k)/cp)**cpor*p00 + ps_p(i,j,k)=(ps_p(i,j,k)/cpdry)**cpor*p00 enddo enddo diff --git a/BRAMS/src/isan/asti2.f90 b/BRAMS/src/isan/asti2.f90 index 2663cc981..d57bb95ae 100644 --- a/BRAMS/src/isan/asti2.f90 +++ b/BRAMS/src/isan/asti2.f90 @@ -290,7 +290,7 @@ subroutine sndproc (lp,lz,xlat,xlon,elev,idsta,tp,zp,pp,rp,dz,fz,zz) use isan_coms use rconstants -use therm_lib, only: ptrh2rvapl,virtt +use therm_lib, only: ptrh2rvapl,virtt,press2exner implicit none real, dimension(*) :: tp,zp,pp,rp,dz,fz,zz @@ -450,7 +450,7 @@ subroutine sndproc (lp,lz,xlat,xlon,elev,idsta,tp,zp,pp,rp,dz,fz,zz) ! Since this is radiosonde, always use liquid water to define vapour mixing ! ! ratio. This is the WMO standard, so we assume the data is in standard form. ! !---------------------------------------------------------------------------------! - rss=ptrh2rvapl(rp(k),pp(k),tp(k)) + rss=ptrh2rvapl(rp(k),pp(k),tp(k),.false.) thz(k)=virtt(thz(k),rss) endif endif @@ -458,28 +458,28 @@ subroutine sndproc (lp,lz,xlat,xlon,elev,idsta,tp,zp,pp,rp,dz,fz,zz) ! Recompute heights -pio=cp*(pp(lbc)/p00)**rocp +pio=press2exner(pp(lbc)) zso=zp(lbc) tho=thz(lbc) do k=lbc+1,lp zp(k)=1.e30 if(pp(k) < 1e19 .and. thz(k) < 1e19)then - zp(k)=zso+.5*(thz(k)+tho)*(pio-cp*(pp(k)/p00)**rocp)/grav + zp(k)=zso+.5*(thz(k)+tho)*(pio-press2exner(pp(k)))/grav zso=zp(k) - pio=cp*(pp(k)/p00)**rocp + pio=press2exner(pp(k)) tho=thz(k) endif enddo zso=zp(lbc) -pio=cp*(pp(lbc)/p00)**rocp +pio=press2exner(pp(lbc)) tho=thz(lbc) do k=lbc-1,1,-1 zp(k)=1.e30 if(pp(k) < 1e19 .and. thz(k) < 1e19)then - zp(k)=zso+.5*(thz(k)+tho)*(pio-cp*(pp(k)/p00)**rocp)/grav + zp(k)=zso+.5*(thz(k)+tho)*(pio-press2exner(pp(k)))/grav zso=zp(k) - pio=cp*(pp(k)/p00)**rocp + pio=press2exner(pp(k)) tho=thz(k) endif enddo @@ -869,12 +869,12 @@ subroutine sfcproc (nasecs,jyr,jmo,jdy,jt,idsta,xlat,xlon & ! Assuming relative humidity with respect to the liquid phase. This is observed ! ! data, and following the WMO convention this should be in liquid phase. ! !------------------------------------------------------------------------------------! - sf_r(nsu)=rehul(px,tx,rslf(px,tdx)) + sf_r(nsu)=rehul(px,tx,rslf(px,tdx),.false.) else sf_r(nsu)=1.e30 endif if(zx.lt.1.e19) then - sf_s(nsu)=cp*tx+grav*zx + sf_s(nsu)=cpdry*tx+grav*zx else sf_s(nsu)=1.e30 endif diff --git a/BRAMS/src/isan/astp.f90 b/BRAMS/src/isan/astp.f90 index f5abbf2b6..c12e1bfff 100644 --- a/BRAMS/src/isan/astp.f90 +++ b/BRAMS/src/isan/astp.f90 @@ -619,9 +619,9 @@ subroutine pr_hystatic_z(np,z1,z2,t1,t2,r1,r2,p1,p2) if(z2(n).lt.1.e20.and.t1(n).lt.1.e20.and. & t2(n).lt.1.e20.and.r1(n).lt.1.e20.and. & r2(n).lt.1.e20 ) then - raux = ptrh2rvapil(r1(n),p1*100.,t1(n)) + raux = ptrh2rvapil(r1(n),p1*100.,t1(n),.false.) tv1=virtt(t1(n),raux) - raux = ptrh2rvapil(r2(n),p2*100.,t2(n)) + raux = ptrh2rvapil(r2(n),p2*100.,t2(n),.false.) tv2=virtt(t2(n),raux) z1(n)=z2(n)- rdry*.5*(tv1+tv2)*(log(p1/p2))/grav !print*,z1(n),z2(n),t1(n),t2(n),tv1,tv2,p1,p2 @@ -638,7 +638,7 @@ subroutine pr_hystatic_z(np,z1,z2,t1,t2,r1,r2,p1,p2) if(t2(n).lt.1.e20.and.z1(n).lt.1.e20 & .and.z2(n).lt.1.e20.and.r1(n).lt.1.e20 & .and.r2(n).lt.1.e20 ) then - raux=ptrh2rvapil(r2(n),p2*100.,t2(n)) + raux=ptrh2rvapil(r2(n),p2*100.,t2(n),.false.) vtfact=virtt(t2(n),raux)/t2(n) t1(n)=-t2(n)- (2.*grav*(z1(n)-z2(n)) & /(rdry *(log(p1/p2))) ) & diff --git a/BRAMS/src/isan/avarf.f90 b/BRAMS/src/isan/avarf.f90 index f832b1bac..496a8f0d4 100644 --- a/BRAMS/src/isan/avarf.f90 +++ b/BRAMS/src/isan/avarf.f90 @@ -94,7 +94,7 @@ subroutine isnsig(n1,n2,n3,uu,vv,tt,rr,pp & .and.pi_u(i,j,ki).lt.1e20.and.pi_v(i,j,ki).lt.1e20) & then nki=nki+1 - v2(nki)=(pi_s(i,j,ki)-cp*levth(ki) & + v2(nki)=(pi_s(i,j,ki)-cpdry*levth(ki) & *(pi_p(i,j,ki)*p00i)**rocp)/grav ! print*,'v2:',i,j,nki,pi_s(i,j,ki),levth(ki),pi_p(i,j,ki) @@ -169,7 +169,7 @@ subroutine visurf(n1,n2,n3,up,vp,thp,rtp,pp,topt,rtgt,zt) use isan_coms use rconstants -use therm_lib, only: rehuil,ptrh2rvapil,virtt +use therm_lib, only: rehuil,ptrh2rvapil,virtt,exner2press,extheta2temp implicit none @@ -205,15 +205,15 @@ subroutine visurf(n1,n2,n3,up,vp,thp,rtp,pp,topt,rtgt,zt) up(k,i,j)=up(k,i,j)*wt+rs_u(i,j)*(1.-wt) if(rs_v(i,j).lt.1.e10) & vp(k,i,j)=vp(k,i,j)*wt+rs_v(i,j)*(1.-wt) - ppp=(pp(k,i,j)/cp)**cpor*p00 - ttt=thp(k,i,j)*pp(k,i,j)/cp - rhm=rehuil(ppp,ttt,rtp(k,i,j)) + ppp=exner2press(pp(k,i,j)) + ttt=extheta2temp(pp(k,i,j),thp(k,i,j)) + rhm=rehuil(ppp,ttt,rtp(k,i,j),.false.) if(rs_r(i,j).lt.1.e10) & rhm=rhm*wt+rs_r(i,j)*(1.-wt) if(rs_t(i,j).lt.1.e10) & thp(k,i,j)=thp(k,i,j)*wt+rs_t(i,j)*(1.-wt) - ttt=thp(k,i,j)*pp(k,i,j)/cp - rtp(k,i,j)=ptrh2rvapil(rhm,ppp,ttt) + ttt=extheta2temp(pp(k,i,j),thp(k,i,j)) + rtp(k,i,j)=ptrh2rvapil(rhm,ppp,ttt,.false.) endif enddo @@ -242,7 +242,7 @@ subroutine vshyd(n1,n2,n3,pp,tt,rr,topt,rtg,zt) use isan_coms use rconstants -use therm_lib, only: ptrh2rvapil,virtt +use therm_lib, only: ptrh2rvapil,virtt,press2exner,exner2press,extheta2temp implicit none integer :: n1,n2,n3 @@ -309,7 +309,7 @@ subroutine vshyd(n1,n2,n3,pp,tt,rr,topt,rtg,zt) ! Integrate P to surface - piibc=cp*(pi_p(i,j,lbc)*p00i)**rocp + piibc=press2exner(pi_p(i,j,lbc)) ziibc=(pi_s(i,j,lbc)-levth(lbc)*piibc)/grav gd2=2.*grav pp(kabc-1,i,j)=piibc+gd2*(ziibc-v3(kabc-1)) & @@ -330,13 +330,13 @@ subroutine vshyd(n1,n2,n3,pp,tt,rr,topt,rtg,zt) ! hydrostatic integration. ! do k=1,n1 - ppp=(pp(k,i,j)/cp)**cpor*p00 - ttt=tt(k,i,j)*pp(k,i,j)/cp - rr(k,i,j)=ptrh2rvapil(rr(k,i,j),ppp,ttt) + ppp=exner2press(pp(k,i,j)) + ttt=extheta2temp(pp(k,i,j),tt(k,i,j)) + rr(k,i,j)=ptrh2rvapil(rr(k,i,j),ppp,ttt,.false.) enddo - tmpbc=levth(lbc)*piibc/cp - rvibc=ptrh2rvapil(pi_r(i,j,lbc),pi_p(i,j,lbc),tmpbc) + tmpbc=extheta2temp(piibc,real(levth(lbc))) + rvibc=ptrh2rvapil(pi_r(i,j,lbc),pi_p(i,j,lbc),tmpbc,.false.) pp(kabc-1,i,j)=piibc+gd2*(ziibc-v3(kabc-1)) & /(virtt(real(levth(lbc)),rvibc) & @@ -358,10 +358,10 @@ subroutine vshyd(n1,n2,n3,pp,tt,rr,topt,rtg,zt) do k=1,n1 ppp=pp(k,i,j) ttt=tt(k,i,j)*(ppp/p00)**rocp - rr(k,i,j)=ptrh2rvapil(rr(k,i,j),ppp,ttt) + rr(k,i,j)=ptrh2rvapil(rr(k,i,j),ppp,ttt,.false.) enddo - pp(1,i,j)= cp*(pp(1,i,j)/p00)**rocp + pp(1,i,j)= press2exner(pp(1,i,j)) do k=2,n1 pp(k,i,j)=pp(k-1,i,j)-grav*(v3(k)-v3(k-1)) & /((virtt(tt(k,i,j),rr(k,i,j))+virtt(tt(k-1,i,j),rr(k-1,i,j)) ) *.5) diff --git a/BRAMS/src/isan/first_rams.f90 b/BRAMS/src/isan/first_rams.f90 index fb11ea24b..1ac8b3bb1 100644 --- a/BRAMS/src/isan/first_rams.f90 +++ b/BRAMS/src/isan/first_rams.f90 @@ -286,6 +286,8 @@ subroutine first_RAMS(np1,np2,np3,ui2,vi2,pi2,ti2,ri2) ,grid_g(ifm)%topt,grid_g(icm)%topt & ,is_grids(ifm)%rr_dn0,is_grids(ifm)%rr_dn0u & ,is_grids(ifm)%rr_dn0v,ztn(:,ifm),ztop ) + deallocate(plt) + deallocate(pltc) endif @@ -332,7 +334,7 @@ subroutine comp_avgv(n1,n2,n3,a) subroutine comp_rhfrac(n1,n2,n3,a,b,c) use rconstants -use therm_lib, only: rehuil +use therm_lib, only: rehuil,exner2press,extheta2temp implicit none integer :: n1,n2,n3 real :: a(n1,n2,n3),b(n1,n2,n3),c(n1,n2,n3) @@ -341,9 +343,9 @@ subroutine comp_rhfrac(n1,n2,n3,a,b,c) do k=1,n3 do j=1,n2 do i=1,n1 - xtemp=c(i,j,k)*b(i,j,k)/cp - xpress=(b(i,j,k)/cp)**cpor*p00 - a(i,j,k)=min(1.,rehuil(xpress,xtemp,a(i,j,k))) + xtemp = extheta2temp(b(i,j,k),c(i,j,k)) + xpress = exner2press (b(i,j,k)) + a(i,j,k) = min(1.,rehuil(xpress,xtemp,a(i,j,k),.false.)) enddo enddo enddo @@ -355,7 +357,7 @@ subroutine comp_rhfrac(n1,n2,n3,a,b,c) subroutine comp_press(n1,n2,n3,a) use rconstants - +use therm_lib, only: exner2press implicit none integer :: n1,n2,n3 real :: a(n1,n2,n3) @@ -363,7 +365,7 @@ subroutine comp_press(n1,n2,n3,a) do k=1,n3 do j=1,n2 do i=1,n1 - a(i,j,k)=(a(i,j,k)/cp)**cpor*p00*.01 + a(i,j,k)=exner2press(a(i,j,k)) * .01 enddo enddo enddo @@ -407,7 +409,7 @@ subroutine isan_comp_dn0 (n1,n2,n3,pi0,th0,dn0,dn0u,dn0v,topt,ngrd) c1=grav*2.*(1.-topt(i,j)/ztop) c2=(1-cpor) - c3=cp**c2 + c3=cpdry**c2 do k=n1-1,1,-1 pi0(k,i,j)=pi0(k+1,i,j) & +c1/((th0(k,i,j)+th0(k+1,i,j))*dzmn(k,ngrd)) @@ -512,6 +514,9 @@ subroutine fmint4_isan(var1,var2,dn0xc,dn0xf,ifm,icm,vpnt,idwt) !call ae1m1(nnzp(ifm)*nnxp(ifm)*nnyp(ifm),plt3b(1,1,1),plt3(1,1,1),var2(1)) !plt(1:nnxp(ifm),1:nnyp(ifm)) =plt3b(12,1:nnxp(ifm),1:nnyp(ifm)) !call ezcntr(plt,nnxp(ifm),nnyp(ifm)) +deallocate (plt) +deallocate (plt3) +deallocate (plt3b) return diff --git a/BRAMS/src/isan/isan_coms.f90 b/BRAMS/src/isan/isan_coms.f90 index 018d29cdf..7ac4ea5e1 100644 --- a/BRAMS/src/isan/isan_coms.f90 +++ b/BRAMS/src/isan/isan_coms.f90 @@ -32,8 +32,8 @@ Module isan_coms !------------------------------------------------------------------------------------ integer, parameter :: maxpr=100 ,maxisn=100 ,maxx=1000 ,maxy=1000 & - ,maxtimes=5000 ,maxagrds=10 ,maxsigz=100 & - ,maxlev=9999 ,maxsname=100000 ,maxisfiles=100000 + ,maxtimes=50000 ,maxagrds=10 ,maxsigz=100 & + ,maxlev=9999 ,maxsname=100000 ,maxisfiles=50000 !--------------------------------------------------------------------------- integer :: ioflgisz,ioflgvar,natime,iszstage,ivrstage,iyear,imonth,idate & ,ihour,isan_inc,i1st_flg,iupa_flg,isfc_flg diff --git a/BRAMS/src/isan/refstate.f90 b/BRAMS/src/isan/refstate.f90 index 3a0a60f61..d3024a043 100644 --- a/BRAMS/src/isan/refstate.f90 +++ b/BRAMS/src/isan/refstate.f90 @@ -42,8 +42,8 @@ subroutine fmrefs1d_isan(ifm,icm,n0,n1 & allocate(vctr1(n1),vctr2(n1),vctr3(n1),vctr4(n1)) -c1 = rdry / (cp - rdry) -c2 = cp * (rdry / p00) ** c1 +c1 = rdry / (cpdry - rdry) +c2 = cpdry * (rdry / p00) ** c1 if (icm >= 1) then do k = 1,n1 vctr1(k) = thref(k,icm) * dnref(k,icm) @@ -101,8 +101,8 @@ subroutine fmrefs3d_isan (ifm,icm,n1f,n2f,n3f,n1c,n2c,n3c & ,ifm,icm,nbot,ntop,jd,1,0,0,'t' & ,th0c,th0f,dn0c,dn0f,scr1,scr2,toptf,vt2da,b(1),b(1),b(1),0) -c1 = rdry / (cp - rdry) -c2 = cp * (rdry / p00) ** c1 +c1 = rdry / (cpdry - rdry) +c2 = cpdry * (rdry / p00) ** c1 pi0f(1:n1f,1:n2f,1:n3f) = c2 * (dn0f(1:n1f,1:n2f,1:n3f) & * th0f(1:n1f,1:n2f,1:n3f) ) ** c1 @@ -267,8 +267,8 @@ subroutine varfile_refstate(n1,n2,n3,thp,pc,pi0,th0,rtp,dn0 & enddo do k = 1,n1 - vctr1(k) = (piref(k) / cp) ** cpor * p00 - dnref(k) = cp * vctr1(k) & + vctr1(k) = (piref(k) / cpdry) ** cpor * p00 + dnref(k) = cpdry * vctr1(k) & / (rdry * thref(k) * piref(k)) enddo @@ -285,7 +285,7 @@ subroutine varfile_refstate(n1,n2,n3,thp,pc,pi0,th0,rtp,dn0 & c1=grav*2.*(1.-topt(i,j)/ztop) c2=(1-cpor) - c3=cp**c2 + c3=cpdry**c2 do k=n1-1,1,-1 pi0(k,i,j)=pi0(k+1,i,j) & +c1*(zt(k+1)-zt(k))/(th0(k,i,j)+th0(k+1,i,j)) diff --git a/BRAMS/src/isan/v_interps.f90 b/BRAMS/src/isan/v_interps.f90 index 48f77681e..654987fb6 100644 --- a/BRAMS/src/isan/v_interps.f90 +++ b/BRAMS/src/isan/v_interps.f90 @@ -123,8 +123,8 @@ SUBROUTINE obs_isen (m1,m2,tsnd,psnd,zsnd,rsnd,usndz,vsndz & cycle staloop end if - syo=cp*pth(lbcp)*pk(lbcp)/p00**rocp+grav*zsnd(ns,lbcp) - obss(ns,lbc)=syo+cp*(pk(lbcp)+obsp(ns,lbc)**rocp) & + syo=cpdry*pth(lbcp)*pk(lbcp)/p00**rocp+grav*zsnd(ns,lbcp) + obss(ns,lbc)=syo+cpdry*(pk(lbcp)+obsp(ns,lbc)**rocp) & *.5/p00**rocp *(levth(lbc)-pth(lbcp)) po=obsp(ns,lbc) syo=obss(ns,lbc) @@ -132,7 +132,7 @@ SUBROUTINE obs_isen (m1,m2,tsnd,psnd,zsnd,rsnd,usndz,vsndz & do k=lbc+1,nisn obss(ns,k)=1e30 if(obsp(ns,k) < 1e19) then - obss(ns,k)=syo+cp*(po**rocp+obsp(ns,k)**rocp) & + obss(ns,k)=syo+cpdry*(po**rocp+obsp(ns,k)**rocp) & *.5/p00**rocp *(levth(k)-tho) syo=obss(ns,k) po=obsp(ns,k) @@ -146,7 +146,7 @@ SUBROUTINE obs_isen (m1,m2,tsnd,psnd,zsnd,rsnd,usndz,vsndz & do k=lbc-1,1,-1 obss(ns,k)=1e30 if(obsp(ns,k).lt.1e19) then - obss(ns,k)=syo+cp*(po**rocp+obsp(ns,k)**rocp)*.5 & + obss(ns,k)=syo+cpdry*(po**rocp+obsp(ns,k)**rocp)*.5 & /p00**rocp*(levth(k)-tho) syo=obss(ns,k) po=obsp(ns,k) @@ -156,7 +156,7 @@ SUBROUTINE obs_isen (m1,m2,tsnd,psnd,zsnd,rsnd,usndz,vsndz & do k=1,nisn if(obss(ns,k).lt.1e19) then - zi(k)=(obss(ns,k)-cp*levth(k)*(obsp(ns,k)*p00i)**rocp)/grav + zi(k)=(obss(ns,k)-cpdry*levth(k)*(obsp(ns,k)*p00i)**rocp)/grav else zi(k)=1e30 endif @@ -334,7 +334,7 @@ SUBROUTINE obs_sigz (m1,m2,tsnd,psnd,zsnd,rsnd,usndz,vsndz & cycle staloop end if - pio=cp*(psnd(ns,lbcp)/p00)**rocp + pio=cpdry*(psnd(ns,lbcp)/p00)**rocp obsp(ns,lbc)=pio-(sigzr(lbc)-zsnd(ns,lbcp))*grav/((pth(lbcp)+obst(ns,lbc))*.5) pio=obsp(ns,lbc) zso=sigzr(lbc) @@ -366,10 +366,10 @@ SUBROUTINE obs_sigz (m1,m2,tsnd,psnd,zsnd,rsnd,usndz,vsndz & DO K=1,nsigz IF(obsp(ns,K)+obst(ns,k) < 1E19) THEN - tsz(k)=obst(ns,k)*obsp(ns,k)/cp - psz(K)=(obsp(ns,k)/cp)**cpor*p00 + tsz(k)=obst(ns,k)*obsp(ns,k)/cpdry + psz(K)=(obsp(ns,k)/cpdry)**cpor*p00 IF(obsr(ns,k).LT.1E19) THEN - rsz(k)=ptrh2rvapl(obsr(ns,k),psz(k),tsz(k)) + rsz(k)=ptrh2rvapl(obsr(ns,k),psz(k),tsz(k),.false.) tsz(k)=virtt(obst(ns,k),rsz(k)) else tsz(k)=obst(ns,k) @@ -412,7 +412,7 @@ SUBROUTINE obs_sigz (m1,m2,tsnd,psnd,zsnd,rsnd,usndz,vsndz & endif enddo do k=1,nsigz - if(obsp(ns,k) < 1e19) obsp(ns,k)=(obsp(ns,k)/cp)**cpor*p00 + if(obsp(ns,k) < 1e19) obsp(ns,k)=(obsp(ns,k)/cpdry)**cpor*p00 enddo ! Vertically interpolate winds in height @@ -573,20 +573,20 @@ subroutine vterpp_i (np1,np2,np3,npi3,un,vn,tn,zn,rn,ui2,vi2,pi2,si2,ri2) endif enddo - sy=cp*thd(kpbc)*pkd(kpbc)/p00k+grav*zn(i,j,kpbc-2) + sy=cpdry*thd(kpbc)*pkd(kpbc)/p00k+grav*zn(i,j,kpbc-2) - si2(i,j,kibc-1)=sy-cp*(pi2(i,j,kibc-1)**rocp & + si2(i,j,kibc-1)=sy-cpdry*(pi2(i,j,kibc-1)**rocp & +ppd(kpbc)**rocp)/(2.*p00k)*(thd(kpbc)-levth(kibc-1)) do k=kibc-2,1,-1 - si2(i,j,k)=si2(i,j,k+1)+cp*(pi2(i,j,k+1)**rocp & + si2(i,j,k)=si2(i,j,k+1)+cpdry*(pi2(i,j,k+1)**rocp & +pi2(i,j,k)**rocp)/(2.*p00k) & *(levth(k)-levth(k+1)) enddo - si2(i,j,kibc)=sy+cp*(pi2(i,j,kibc)**rocp & + si2(i,j,kibc)=sy+cpdry*(pi2(i,j,kibc)**rocp & +ppd(kpbc)**rocp)/(2.*p00k)*(levth(kibc)-thd(kpbc)) do k=kibc+1,nisn - si2(i,j,k)=si2(i,j,k-1)+cp*(pi2(i,j,k-1)**rocp & + si2(i,j,k)=si2(i,j,k-1)+cpdry*(pi2(i,j,k-1)**rocp & +pi2(i,j,k)**rocp)/(2.*p00k) & *(levth(k)-levth(k-1)) enddo @@ -685,9 +685,9 @@ subroutine vterpp_s (np1,np2,np3,npi3,un,vn,tn,zn,rn & npd=nprz+2 DO K=1,NPD PKD(K)=PPD(K)**ROCP - pid(k)=cp*(ppd(k)/p00)**rocp - tempd(k)=thetd(k)*pid(k)/cp - rtd(k)=ptrh2rvapil(rd(k),ppd(k),tempd(k)) + pid(k)=cpdry*(ppd(k)/p00)**rocp + tempd(k)=thetd(k)*pid(k)/cpdry + rtd(k)=ptrh2rvapil(rd(k),ppd(k),tempd(k),.false.) thvd(k)=virtt(thetd(k),rtd(k)) ENDDO @@ -710,7 +710,7 @@ subroutine vterpp_s (np1,np2,np3,npi3,un,vn,tn,zn,rn & call htint(npd,pid,zd,npi3,vvv,sigzr) call psfill(npi3,vvv,pi2,np1,np2,i,j) do k=1,npi3 - pi2(i,j,k)=(pi2(i,j,k)/cp)**cpor*p00 + pi2(i,j,k)=(pi2(i,j,k)/cpdry)**cpor*p00 enddo DO KL=Npi3,1,-1 @@ -748,14 +748,14 @@ subroutine vterpp_s (np1,np2,np3,npi3,un,vn,tn,zn,rn & do k=1,npi3 vvv(k)=ti2(i,j,k)*(pi2(i,j,k)/p00)**rocp - raux =ptrh2rvapil(ri2(i,j,k),pi2(i,j,k),vvv(k)) + raux =ptrh2rvapil(ri2(i,j,k),pi2(i,j,k),vvv(k),.false.) vvv(k)=virtt(ti2(i,j,k),raux) enddo - raux = ptrh2rvapil(rd(kpbc),ppd(kpbc),tempd(kpbc)) + raux = ptrh2rvapil(rd(kpbc),ppd(kpbc),tempd(kpbc),.false.) thvp=virtt(thetd(kpbc),raux) - piibc=cp*pkd(kpbc)/p00**rocp + piibc=cpdry*pkd(kpbc)/p00**rocp pi2(i,j,kibc-1)=piibc+(zd(kpbc)-sigzr(kibc-1))*grav/(.5*(thvp+vvv(kibc-1))) do k=kibc-2,1,-1 pi2(i,j,k)=pi2(i,j,k+1)+(sigzr(k+1)-sigzr(k))*grav/(.5*(vvv(k+1)+vvv(k))) @@ -765,7 +765,7 @@ subroutine vterpp_s (np1,np2,np3,npi3,un,vn,tn,zn,rn & pi2(i,j,k)=pi2(i,j,k-1)-(sigzr(k)-sigzr(k-1))*grav/(.5*(vvv(k-1)+vvv(k))) enddo do k=1,npi3 - pi2(i,j,k)=(pi2(i,j,k)/cp)**cpor*p00 + pi2(i,j,k)=(pi2(i,j,k)/cpdry)**cpor*p00 enddo 4500 continue diff --git a/BRAMS/src/lib/hdf5_utils.F90 b/BRAMS/src/lib/hdf5_utils.F90 index 4a9b1ac2e..e611efd61 100644 --- a/BRAMS/src/lib/hdf5_utils.F90 +++ b/BRAMS/src/lib/hdf5_utils.F90 @@ -475,6 +475,7 @@ subroutine shdf5_irec_f(ndims,dims,dsetname,ivara,rvara,cvara,dvara,lvara & allocate(dvaraTEMP(1:dims(1))) call h5dread_f(dsetid_f,H5T_NATIVE_DOUBLE,dvaraTEMP, dimshf, hdferr ) rvara(1:dims(1)) = sngl(dvaraTEMP(1:dims(1))) + deallocate(dvaraTEMP) stop endif diff --git a/BRAMS/src/lib/numutils.f90 b/BRAMS/src/lib/numutils.f90 index 334cfa37e..923794b80 100644 --- a/BRAMS/src/lib/numutils.f90 +++ b/BRAMS/src/lib/numutils.f90 @@ -1,139 +1,103 @@ -!############################# Change Log ################################## -! 2.0.0 -! -!########################################################################### -! Copyright (C) 1990, 1995, 1999, 2000, 2003 - All Rights Reserved -! Regional Atmospheric Modeling System - RAMS -!########################################################################### +!==========================================================================================! +!==========================================================================================! +! Change Log ! +! 2.0.0 ! +! ! +!------------------------------------------------------------------------------------------! +! Copyright (C) 1990, 1995, 1999, 2000, 2003 - All Rights Reserved ! +! Regional Atmospheric Modeling System - RAMS ! +!==========================================================================================! +!==========================================================================================! -subroutine azerov(n1) -implicit none -integer :: n,n1 -real :: a1(n1),a2(n1),a3(n1),a4(n1),a5(n1) -entry azero(n1,a1) - do n=1,n1 - a1(n)=0. - enddo -return -entry azero2(n1,a1,a2) - do n=1,n1 - a1(n)=0. - a2(n)=0. - enddo -return -entry azero3(n1,a1,a2,a3) - do n=1,n1 - a1(n)=0. - a2(n)=0. - a3(n)=0. - enddo -return -entry azero4(n1,a1,a2,a3,a4) - do n=1,n1 - a1(n)=0. - a2(n)=0. - a3(n)=0. - a4(n)=0. - enddo -return -entry azero5(n1,a1,a2,a3,a4,a5) - do n=1,n1 - a1(n)=0. - a2(n)=0. - a3(n)=0. - a4(n)=0. - a5(n)=0. - enddo -return -end -![MLO ---- Similar to azerov, but for integers. -subroutine izerov(n1) - implicit none - integer :: n,n1 - integer :: ijk1(n1),ijk2(n1),ijk3(n1),ijk4(n1),ijk5(n1) - entry izero(n1,ijk1) - do n=1,n1 - ijk1(n)=0 - enddo - return - entry izero2(n1,ijk1,ijk2) - do n=1,n1 - ijk1(n)=0 - ijk2(n)=0 - enddo - return - entry izero3(n1,ijk1,ijk2,ijk3) - do n=1,n1 - ijk1(n)=0 - ijk2(n)=0 - ijk3(n)=0 - enddo - return - entry izero4(n1,ijk1,ijk2,ijk3,ijk4) - do n=1,n1 - ijk1(n)=0 - ijk2(n)=0 - ijk3(n)=0 - ijk4(n)=0 - enddo - return - entry izero5(n1,ijk1,ijk2,ijk3,ijk4,ijk5) - do n=1,n1 - ijk1(n)=0 - ijk2(n)=0 - ijk3(n)=0 - ijk4(n)=0 - ijk5(n)=0 - enddo - return -end subroutine izerov -![MLO - Just to generate a matrix full of ones... -subroutine aonev(n1) -implicit none -integer :: n,n1 -real :: a1(n1),a2(n1),a3(n1),a4(n1),a5(n1) -entry aone(n1,a1) - do n=1,n1 - a1(n)=1. - enddo -return -entry aone2(n1,a1,a2) - do n=1,n1 - a1(n)=1. - a2(n)=1. - enddo -return -entry aone3(n1,a1,a2,a3) - do n=1,n1 - a1(n)=1. - a2(n)=1. - a3(n)=1. - enddo -return -entry aone4(n1,a1,a2,a3,a4) - do n=1,n1 - a1(n)=1. - a2(n)=1. - a3(n)=1. - a4(n)=1. - enddo -return -entry aone5(n1,a1,a2,a3,a4,a5) - do n=1,n1 - a1(n)=1. - a2(n)=1. - a3(n)=1. - a4(n)=1. - a5(n)=1. - enddo -return -end subroutine aonev -!MLO] + + +!==========================================================================================! +!==========================================================================================! +! This sub-routine flushes all elements of this array to zero. Legacy from the old ! +! code, when vector operations didn't exist. ! +!------------------------------------------------------------------------------------------! +subroutine azero(nmax,arr) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: nmax + real , dimension(nmax), intent(out) :: arr + !----- Local variables. ----------------------------------------------------------------! + integer :: n + !---------------------------------------------------------------------------------------! + + do n=1,nmax + arr(n) = 0. + end do + + return +end subroutine azero +!==========================================================================================! +!==========================================================================================! + + + + + +!==========================================================================================! +!==========================================================================================! +! This sub-routine flushes all elements of this array to zero. Legacy from the old ! +! code, when vector operations didn't exist. The only difference between this one and ! +! azero is that the input vector here is integer. ! +!------------------------------------------------------------------------------------------! +subroutine izero(nmax,arr) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: nmax + integer, dimension(nmax), intent(out) :: arr + !----- Local variables. ----------------------------------------------------------------! + integer :: n + !---------------------------------------------------------------------------------------! + + do n=1,nmax + arr(n) = 0 + end do + + return +end subroutine izero +!==========================================================================================! +!==========================================================================================! + + + + + +!==========================================================================================! +!==========================================================================================! +! This sub-routine flushes all elements of this array to one. Legacy from the old ! +! code, when vector operations didn't exist. ! +!------------------------------------------------------------------------------------------! +subroutine aone(nmax,arr) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: nmax + real , dimension(nmax), intent(out) :: arr + !----- Local variables. ----------------------------------------------------------------! + integer :: n + !---------------------------------------------------------------------------------------! + + do n=1,nmax + arr(n) = 1. + end do + + return +end subroutine aone +!==========================================================================================! +!==========================================================================================! + + + +!==========================================================================================! +!==========================================================================================! subroutine ae1t0(n1,a,b,c) implicit none integer :: n1 @@ -2296,3 +2260,202 @@ real(kind=8) function eifun8(x) end function eifun8 !==========================================================================================! !==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +! This subroutine extracts a vertical (z) column given a 3-D array, and the fixed ! +! indices for the x and y dimensions. ! +!------------------------------------------------------------------------------------------! +subroutine array2zcol(mz,mx,my,x,y,array,vector) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: mz + integer , intent(in) :: mx + integer , intent(in) :: my + integer , intent(in) :: x + integer , intent(in) :: y + real(kind=4), dimension(mz,mx,my), intent(in) :: array + real(kind=4), dimension(mz) , intent(out) :: vector + !----- Local variables. ----------------------------------------------------------------! + integer :: z + !---------------------------------------------------------------------------------------! + + do z=1,mz + vector(z) = array(z,x,y) + end do + + return +end subroutine array2zcol +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +! This subroutine extracts a longitudinal (x) column given a 3-D array, and the fixed ! +! indices for the z and y dimensions. ! +!------------------------------------------------------------------------------------------! +subroutine array2xcol(mz,mx,my,z,y,array,vector) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: mz + integer , intent(in) :: mx + integer , intent(in) :: my + integer , intent(in) :: z + integer , intent(in) :: y + real(kind=4), dimension(mz,mx,my), intent(in) :: array + real(kind=4), dimension(mx) , intent(out) :: vector + !----- Local variables. ----------------------------------------------------------------! + integer :: x + !---------------------------------------------------------------------------------------! + + do x=1,mx + vector(x) = array(z,x,y) + end do + + return +end subroutine array2xcol +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +! This subroutine extracts a latitudinal (y) column given a 3-D array, and the fixed ! +! indices for the z and x dimensions. ! +!------------------------------------------------------------------------------------------! +subroutine array2ycol(mz,mx,my,z,x,array,vector) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: mz + integer , intent(in) :: mx + integer , intent(in) :: my + integer , intent(in) :: z + integer , intent(in) :: x + real(kind=4), dimension(mz,mx,my), intent(in) :: array + real(kind=4), dimension(my) , intent(out) :: vector + !----- Local variables. ----------------------------------------------------------------! + integer :: y + !---------------------------------------------------------------------------------------! + + do y=1,my + vector(y) = array(z,x,y) + end do + + return +end subroutine array2ycol +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +! This subroutine copies a vertical (z) column to a 3-D array, using fixed indices for ! +! the x and y dimensions. ! +!------------------------------------------------------------------------------------------! +subroutine zcol2array(mz,mx,my,x,y,vector,array) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: mz + integer , intent(in) :: mx + integer , intent(in) :: my + integer , intent(in) :: x + integer , intent(in) :: y + real(kind=4), dimension(mz) , intent(in) :: vector + real(kind=4), dimension(mz,mx,my), intent(inout) :: array + !----- Local variables. ----------------------------------------------------------------! + integer :: z + !---------------------------------------------------------------------------------------! + + do z=1,mz + array(z,x,y) = vector(z) + end do + + return +end subroutine zcol2array +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +! This subroutine copies a longitudinal (x) column to a 3-D array, using fixed indices ! +! for the z and y dimensions. ! +!------------------------------------------------------------------------------------------! +subroutine xcol2array(mz,mx,my,z,y,vector,array) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: mz + integer , intent(in) :: mx + integer , intent(in) :: my + integer , intent(in) :: z + integer , intent(in) :: y + real(kind=4), dimension(mx) , intent(in) :: vector + real(kind=4), dimension(mz,mx,my), intent(inout) :: array + !----- Local variables. ----------------------------------------------------------------! + integer :: x + !---------------------------------------------------------------------------------------! + + do x=1,mx + array(z,x,y) = vector(x) + end do + + return +end subroutine xcol2array +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +! This subroutine copies a latitudinal (y) column to a 3-D array, using fixed indices ! +! for the z and x dimensions. ! +!------------------------------------------------------------------------------------------! +subroutine ycol2array(mz,mx,my,z,x,vector,array) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: mz + integer , intent(in) :: mx + integer , intent(in) :: my + integer , intent(in) :: z + integer , intent(in) :: x + real(kind=4), dimension(my) , intent(in) :: vector + real(kind=4), dimension(mz,mx,my), intent(inout) :: array + !----- Local variables. ----------------------------------------------------------------! + integer :: y + !---------------------------------------------------------------------------------------! + + do y=1,my + array(z,x,y) = vector(y) + end do + + return +end subroutine ycol2array +!==========================================================================================! +!==========================================================================================! + diff --git a/BRAMS/src/lib/rconstants.f90 b/BRAMS/src/lib/rconstants.f90 index a0374808d..a6ce06241 100644 --- a/BRAMS/src/lib/rconstants.f90 +++ b/BRAMS/src/lib/rconstants.f90 @@ -152,23 +152,23 @@ Module rconstants !---------------------------------------------------------------------------------------! ! Dry air properties ! !---------------------------------------------------------------------------------------! - real, parameter :: rdry = rmol/mmdry ! Gas constant for dry air (Ra) [ J/kg/K] - real, parameter :: rdryi = mmdry/rmol ! 1./Gas constant for dry air (Ra) [ kg K/J] - real, parameter :: cp = 3.5 * rdry ! Specific heat at constant press. [ J/kg/K] - real, parameter :: cv = 2.5 * rdry ! Specific heat at constant volume [ J/kg/K] - real, parameter :: cpog = cp /grav ! cp/g [ m/K] - real, parameter :: rocp = rdry / cp ! Ra/cp [ ----] - real, parameter :: rocv = rdry / cv ! Ra/Cv [ ----] - real, parameter :: cpocv = cp / cv ! Cp/Cv [ ----] - real, parameter :: cpor = cp / rdry ! Cp/Ra [ ----] - real, parameter :: cvor = cv / rdry ! Cp/Ra [ ----] - real, parameter :: gocp = grav / cp ! g/Cp, dry adiabatic lapse rate [ K/m] - real, parameter :: gordry = grav / rdry ! g/Ra [ K/m] - real, parameter :: cpi = 1. / cp ! 1/Cp [ kg K/J] - real, parameter :: cpi4 = 4. * cpi ! 4/Cp [ kg K/J] - real, parameter :: p00or = p00 / rdry ! p0 ** (Ra/Cp) [ Pa^2/7] - real, parameter :: p00k = 26.8269579527 ! p0 ** (Ra/Cp) [ Pa^2/7] - real, parameter :: p00ki = 1. / p00k ! p0 ** (-Ra/Cp) [ Pa^-2/7] + real, parameter :: rdry = rmol/mmdry ! Gas constant for dry air (Ra) [ J/kg/K] + real, parameter :: rdryi = mmdry/rmol ! 1./Gas const. for dry air (Ra) [ kg K/J] + real, parameter :: cpdry = 3.5 * rdry ! Spec. heat at constant press. [ J/kg/K] + real, parameter :: cvdry = 2.5 * rdry ! Spec. heat at constant volume [ J/kg/K] + real, parameter :: cpog = cpdry /grav ! cp/g [ m/K] + real, parameter :: rocp = rdry / cpdry ! Ra/cp [ ----] + real, parameter :: rocv = rdry / cvdry ! Ra/Cv [ ----] + real, parameter :: cpocv = cpdry / cvdry ! Cp/Cv [ ----] + real, parameter :: cpor = cpdry / rdry ! Cp/Ra [ ----] + real, parameter :: cvor = cvdry / rdry ! Cp/Ra [ ----] + real, parameter :: gocp = grav / cpdry ! g/Cp, dry adiabatic lapse rate [ K/m] + real, parameter :: gordry = grav / rdry ! g/Ra [ K/m] + real, parameter :: cpdryi = 1. / cpdry ! 1/Cp [ kg K/J] + real, parameter :: cpdryi4 = 4. * cpdryi ! 4/Cp [ kg K/J] + real, parameter :: p00or = p00 / rdry ! p0 ** (Ra/Cp) [ Pa^2/7] + real, parameter :: p00k = 26.8269579527 ! p0 ** (Ra/Cp) [ Pa^2/7] + real, parameter :: p00ki = 1. / p00k ! p0 ** (-Ra/Cp) [ Pa^-2/7] !---------------------------------------------------------------------------------------! @@ -177,11 +177,13 @@ Module rconstants ! Water vapour properties ! !---------------------------------------------------------------------------------------! real, parameter :: rh2o = rmol/mmh2o ! Gas const. for water vapour (Rv) [ J/kg/K] + real, parameter :: cph2o = 1859. ! Heat capacity at const. pres. [ J/kg/K] + real, parameter :: cph2oi = 1. / cph2o ! Inverse of heat capacity [ kg K/J] + real, parameter :: cvh2o = cph2o-rh2o ! Heat capacity at const. volume [ J/kg/K] real, parameter :: gorh2o = grav / rh2o ! g/Rv [ K/m] real, parameter :: ep = mmh2o/mmdry ! or Ra/Rv, epsilon [ kg/kg] real, parameter :: epi = mmdry/mmh2o ! or Rv/Ra, 1/epsilon [ kg/kg] real, parameter :: epim1 = epi-1. ! that 0.61 term of virtual temp. [ kg/kg] - real, parameter :: rh2oocp = rh2o / cp ! Rv/cp [ ----] real, parameter :: toodry = 1.e-8 ! Minimum acceptable mixing ratio. [ kg/kg] real, parameter :: toowet = 3.e-2 ! Maximum acceptable mixing ratio. [ kg/kg] !---------------------------------------------------------------------------------------! @@ -194,7 +196,6 @@ Module rconstants real, parameter :: wdns = 1.000e3 ! Liquid water density [ kg/m³] real, parameter :: wdnsi = 1./wdns ! Inverse of liquid water density [ m³/kg] real, parameter :: cliq = 4.186e3 ! Liquid water specific heat (Cl) [ J/kg/K] - real, parameter :: cliqvlme = wdns*cliq ! Water heat capacity × water dens. [ J/m³/K] real, parameter :: cliqi = 1./cliq ! Inverse of water heat capacity [ kg K/J] !---------------------------------------------------------------------------------------! @@ -208,7 +209,6 @@ Module rconstants real, parameter :: fdns = 2.000e2 ! Frost density [ kg/m³] real, parameter :: fdnsi = 1./fdns ! Inverse of frost density [ m³/kg] real, parameter :: cice = 2.093e3 ! Ice specific heat (Ci) [ J/kg/K] - real, parameter :: cicevlme = wdns * cice ! Heat capacity × water density [ J/m³/K] real, parameter :: cicei = 1. / cice ! Inverse of ice heat capacity [ kg K/J] !---------------------------------------------------------------------------------------! @@ -217,40 +217,50 @@ Module rconstants !---------------------------------------------------------------------------------------! ! Phase change properties ! !---------------------------------------------------------------------------------------! - real, parameter :: t3ple = 273.16 ! Water triple point temp. (T3) [ K] - real, parameter :: t3plei = 1./t3ple ! 1./T3 [ 1/K] - real, parameter :: es3ple = 611.65685464 ! Vapour pressure at T3 (es3) [ Pa] - real, parameter :: es3plei = 1./es3ple ! 1./es3 [ 1/Pa] - real, parameter :: epes3ple = ep * es3ple ! epsilon × es3 [ Pa kg/kg] - real, parameter :: rh2ot3ple = rh2o * t3ple ! Rv × T3 [ J/kg] - real, parameter :: alvl = 2.50e6 ! Lat. heat - vaporisation (Lv) [ J/kg] - real, parameter :: alvi = 2.834e6 ! Lat. heat - sublimation (Ls) [ J/kg] - real, parameter :: alli = 3.34e5 ! Lat. heat - fusion (Lf) [ J/kg] - real, parameter :: allivlme = wdns * alli ! Lat. heat × water density [ J/m³] - real, parameter :: alvl2 = alvl * alvl ! Lv² [ J²/kg²] - real, parameter :: alvi2 = alvi * alvi ! Ls² [ J²/kg²] - real, parameter :: allii = 1. / alli ! 1./Lf [ kg/J] - real, parameter :: aklv = alvl / cp ! Lv/Cp [ K] - real, parameter :: akiv = alvi / cp ! Ls/Cp [ K] - real, parameter :: lvordry = alvl / rdry ! Lv/Ra [ K] - real, parameter :: lvorvap = alvl / rh2o ! Lv/Rv [ K] - real, parameter :: lsorvap = alvi / rh2o ! Ls/Rv [ K] - real, parameter :: lvt3ple = alvl * t3ple ! Lv × T3 [ K J/kg] - real, parameter :: lst3ple = alvi * t3ple ! Ls × T3 [ K J/kg] - real, parameter :: qicet3 = cice * t3ple ! q at triple point, only ice [ J/kg] - real, parameter :: qliqt3 = qicet3 + alli ! q at triple point, only liq. [ J/kg] - !---------------------------------------------------------------------------------------! - - - - !---------------------------------------------------------------------------------------! - ! Tsupercool is the temperature of supercooled water that will cause the energy to ! - ! be the same as ice at 0K. It can be used as an offset for temperature when defining ! - ! internal energy. The next two methods of defining the internal energy for the liquid ! - ! part: ! + real, parameter :: t3ple = 273.16 ! Water triple point temp. (T3)[ K] + real, parameter :: t3plei = 1./t3ple ! 1./T3 [ 1/K] + real, parameter :: es3ple = 611.65685464 ! Vapour pressure at T3 (es3) [ Pa] + real, parameter :: es3plei = 1./es3ple ! 1./es3 [ 1/Pa] + real, parameter :: epes3ple = ep * es3ple ! epsilon × es3 [ Pa kg/kg] + real, parameter :: rh2ot3ple = rh2o * t3ple ! Rv × T3 [ J/kg] + real, parameter :: alli = 3.34e5 ! Lat. heat - fusion (Lf)[ J/kg] + real, parameter :: alvl3 = 2.50e6 ! Lat. heat - vaporisation (Lv)[ J/kg] + real, parameter :: alvi3 = alli + alvl3 ! Lat. heat - sublimation (Ls)[ J/kg] + real, parameter :: allii = 1. / alli ! 1./Lf [ kg/J] + real, parameter :: aklv = alvl3 / cpdry ! Lv/Cp [ K] + real, parameter :: akiv = alvi3 / cpdry ! Ls/Cp [ K] + real, parameter :: lvordry = alvl3 / rdry ! Lv/Ra [ K] + real, parameter :: lvorvap = alvl3 / rh2o ! Lv/Rv [ K] + real, parameter :: lsorvap = alvi3 / rh2o ! Ls/Rv [ K] + real, parameter :: lvt3ple = alvl3 * t3ple ! Lv × T3 [ K J/kg] + real, parameter :: lst3ple = alvi3 * t3ple ! Ls × T3 [ K J/kg] + real, parameter :: uiicet3 = cice * t3ple ! u at triple point, only ice [ J/kg] + real, parameter :: uiliqt3 = uiicet3 + alli ! u at triple point, only liq. [ J/kg] + real, parameter :: dcpvl = cph2o - cliq ! difference of sp. heat [ J/kg/K] + real, parameter :: dcpvi = cph2o - cice ! difference of sp. heat [ J/kg/K] + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! The following variables are useful when defining the derivatives of theta_il. ! + ! They correspond to L?(T) - L?' T. ! + !---------------------------------------------------------------------------------------! + real, parameter :: del_alvl3 = alvl3 - dcpvl * t3ple + real, parameter :: del_alvi3 = alvi3 - dcpvi * t3ple + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! Tsupercool are defined as temperatures of supercooled liquid water (water vapour) ! + ! that will cause the internal energy (enthalpy) to be the same as ice at 0K. It can ! + ! be used as an offset for temperature when defining internal energy (enthalpy). The ! + ! next two methods of defining the internal energy for the liquid part: ! ! ! - ! Uliq = Mliq × [ Cice × T3 + Cliq × (T - T3) + Lf] ! - ! Uliq = Mliq × Cliq × (T - Tsupercool) ! + ! Uliq = Mliq [ Cice T3 + Cliq (T - T3) + Lf] ! + ! Uliq = Mliq Cliq (T - Tsupercool_liq) ! + ! ! + ! H = Mliq [ Cice T3 + Cliq (Ts - T3) + Lv3 + (Cpv - Cliq) (Ts-T3) + Cpv (T-T3) ] ! + ! H = Mliq Cpv (T - Tsupercool_vap) ] ! ! ! ! You may be asking yourself why would we have the ice term in the internal energy ! ! definition. The reason is that we can think that internal energy is the amount of ! @@ -258,20 +268,8 @@ Module rconstants ! prefer the inverse way, Uliq is the amount of energy the parcel would need to lose to ! ! become solid at 0K.) ! !---------------------------------------------------------------------------------------! - real, parameter :: tsupercool = t3ple - (qicet3+alli) * cliqi - !---------------------------------------------------------------------------------------! - - - - !---------------------------------------------------------------------------------------! - ! eta3ple is a constant related to the triple point that is used to find enthalpy ! - ! when the equilibrium temperature is above t3ple. cimcp (clmcp) is the difference ! - ! between the heat capacity of ice (liquid) and vapour, the latter assumed to be the ! - ! same as the dry air, for simplicity. ! - !---------------------------------------------------------------------------------------! - real, parameter :: eta3ple = (cice - cliq) * t3ple + alvi - real, parameter :: cimcp = cice - cp - real, parameter :: clmcp = cliq - cp + real, parameter :: tsupercool_liq = t3ple - (uiicet3 + alli ) * cliqi + real, parameter :: tsupercool_vap = t3ple - (uiicet3 + alvi3) * cph2oi !---------------------------------------------------------------------------------------! @@ -285,9 +283,9 @@ Module rconstants ! ature as a thermodynamic variable in deep atmospheric models. Mon. Wea. Rev., ! ! v. 109, 1094-1102. ! !---------------------------------------------------------------------------------------! - real, parameter :: ttripoli = 253. ! "Tripoli-Cotton" temp. (Ttr) [ K] - real, parameter :: htripoli = cp*ttripoli ! Sensible enthalpy at T=Ttr [ J/kg] - real, parameter :: htripolii = 1./htripoli ! 1./htripoli [ kg/J] + real, parameter :: ttripoli = 253. ! "Tripoli-Cotton" temp. (Ttr) [ K] + real, parameter :: htripoli = cpdry*ttripoli ! Sensible enthalpy at T=Ttr [ J/kg] + real, parameter :: htripolii = 1./htripoli ! 1./htripoli [ kg/J] !---------------------------------------------------------------------------------------! @@ -377,16 +375,19 @@ Module rconstants real(kind=8), parameter :: p00ki8 = dble(p00ki ) real(kind=8), parameter :: rdry8 = dble(rdry ) real(kind=8), parameter :: rdryi8 = dble(rdryi ) - real(kind=8), parameter :: cp8 = dble(cp ) - real(kind=8), parameter :: cv8 = dble(cv ) + real(kind=8), parameter :: cpdry8 = dble(cpdry ) + real(kind=8), parameter :: cvdry8 = dble(cvdry ) real(kind=8), parameter :: cpog8 = dble(cpog ) real(kind=8), parameter :: rocp8 = dble(rocp ) real(kind=8), parameter :: rocv8 = dble(rocv ) real(kind=8), parameter :: cpocv8 = dble(cpocv ) real(kind=8), parameter :: cpor8 = dble(cpor ) - real(kind=8), parameter :: cpi8 = dble(cpi ) - real(kind=8), parameter :: cpi48 = dble(cpi4 ) + real(kind=8), parameter :: cpdryi8 = dble(cpdryi ) + real(kind=8), parameter :: cpdryi48 = dble(cpdryi4 ) real(kind=8), parameter :: rh2o8 = dble(rh2o ) + real(kind=8), parameter :: cph2o8 = dble(cph2o ) + real(kind=8), parameter :: cph2oi8 = dble(cph2oi ) + real(kind=8), parameter :: cvh2o8 = dble(cvh2o ) real(kind=8), parameter :: gorh2o8 = dble(gorh2o ) real(kind=8), parameter :: ep8 = dble(ep ) real(kind=8), parameter :: epi8 = dble(epi ) @@ -395,33 +396,32 @@ Module rconstants real(kind=8), parameter :: wdns8 = dble(wdns ) real(kind=8), parameter :: wdnsi8 = dble(wdnsi ) real(kind=8), parameter :: cliq8 = dble(cliq ) - real(kind=8), parameter :: cliqvlme8 = dble(cliqvlme ) real(kind=8), parameter :: cliqi8 = dble(cliqi ) real(kind=8), parameter :: idns8 = dble(idns ) real(kind=8), parameter :: idnsi8 = dble(idnsi ) real(kind=8), parameter :: fdns8 = dble(fdns ) real(kind=8), parameter :: fdnsi8 = dble(fdnsi ) real(kind=8), parameter :: cice8 = dble(cice ) - real(kind=8), parameter :: cicevlme8 = dble(cicevlme ) real(kind=8), parameter :: cicei8 = dble(cicei ) real(kind=8), parameter :: t3ple8 = dble(t3ple ) real(kind=8), parameter :: t3plei8 = dble(t3plei ) real(kind=8), parameter :: es3ple8 = dble(es3ple ) real(kind=8), parameter :: es3plei8 = dble(es3plei ) real(kind=8), parameter :: epes3ple8 = dble(epes3ple ) - real(kind=8), parameter :: alvl8 = dble(alvl ) - real(kind=8), parameter :: alvi8 = dble(alvi ) + real(kind=8), parameter :: alvl38 = dble(alvl3 ) + real(kind=8), parameter :: alvi38 = dble(alvi3 ) real(kind=8), parameter :: alli8 = dble(alli ) - real(kind=8), parameter :: allivlme8 = dble(allivlme ) real(kind=8), parameter :: allii8 = dble(allii ) real(kind=8), parameter :: akiv8 = dble(akiv ) real(kind=8), parameter :: aklv8 = dble(aklv ) - real(kind=8), parameter :: qicet38 = dble(qicet3 ) - real(kind=8), parameter :: qliqt38 = dble(qliqt3 ) - real(kind=8), parameter :: tsupercool8 = dble(tsupercool ) - real(kind=8), parameter :: eta3ple8 = dble(eta3ple ) - real(kind=8), parameter :: cimcp8 = dble(cimcp ) - real(kind=8), parameter :: clmcp8 = dble(clmcp ) + real(kind=8), parameter :: uiicet38 = dble(uiicet3 ) + real(kind=8), parameter :: uiliqt38 = dble(uiliqt3 ) + real(kind=8), parameter :: dcpvl8 = dble(dcpvl ) + real(kind=8), parameter :: dcpvi8 = dble(dcpvi ) + real(kind=8), parameter :: del_alvl38 = dble(del_alvl3 ) + real(kind=8), parameter :: del_alvi38 = dble(del_alvi3 ) + real(kind=8), parameter :: tsupercool_liq8 = dble(tsupercool_liq) + real(kind=8), parameter :: tsupercool_vap8 = dble(tsupercool_vap) real(kind=8), parameter :: ttripoli8 = dble(ttripoli ) real(kind=8), parameter :: htripoli8 = dble(htripoli ) real(kind=8), parameter :: htripolii8 = dble(htripolii ) @@ -434,6 +434,7 @@ Module rconstants real(kind=8), parameter :: th_diff8 = dble(th_diff ) real(kind=8), parameter :: th_diffi8 = dble(th_diffi ) real(kind=8), parameter :: kin_visc8 = dble(kin_visc ) + real(kind=8), parameter :: kin_visci8 = dble(kin_visci ) real(kind=8), parameter :: th_expan8 = dble(th_expan ) real(kind=8), parameter :: gr_coeff8 = dble(gr_coeff ) real(kind=8), parameter :: lnexp_min8 = dble(lnexp_min ) @@ -446,3 +447,5 @@ Module rconstants end module rconstants +!==========================================================================================! +!==========================================================================================! diff --git a/BRAMS/src/lib/therm_lib.f90 b/BRAMS/src/lib/therm_lib.f90 index 72b8c598b..0468390af 100644 --- a/BRAMS/src/lib/therm_lib.f90 +++ b/BRAMS/src/lib/therm_lib.f90 @@ -57,13 +57,16 @@ module therm_lib ! These equations give the triple point at t3ple, with vapour pressure being es3ple. ! !---------------------------------------------------------------------------------------! !----- Coefficients based on equation (7): ---------------------------------------------! - real, dimension(0:3), parameter :: iii_7 = (/ 9.550426,-5723.265, 3.53068,-0.00728332 /) + real(kind=4), dimension(0:3), parameter :: iii_7 = (/ 9.550426, -5723.265 & + , 3.530680, -0.00728332 /) !----- Coefficients based on equation (10), first fit ----------------------------------! - real, dimension(0:3), parameter :: l01_10= (/54.842763,-6763.22 ,-4.210 , 0.000367 /) + real(kind=4), dimension(0:3), parameter :: l01_10 = (/ 54.842763, -6763.220 & + , -4.210 , 0.000367 /) !----- Coefficients based on equation (10), second fit ---------------------------------! - real, dimension(0:3), parameter :: l02_10= (/53.878 ,-1331.22 ,-9.44523, 0.014025 /) + real(kind=4), dimension(0:3), parameter :: l02_10 = (/ 53.878 , -1331.22 & + , -9.44523 , 0.014025 /) !----- Coefficients based on the hyperbolic tangent ------------------------------------! - real, dimension(2) , parameter :: ttt_10= (/0.0415,218.8/) + real(kind=4), dimension(2) , parameter :: ttt_10 = (/ 0.0415 , 218.80 /) !---------------------------------------------------------------------------------------! @@ -80,44 +83,70 @@ module therm_lib ! what was on the original code... ! !---------------------------------------------------------------------------------------! !----- Coefficients for esat (liquid) --------------------------------------------------! - real, dimension(0:8), parameter :: cll = (/ .6105851e+03, .4440316e+02, .1430341e+01 & - , .2641412e-01, .2995057e-03, .2031998e-05 & - , .6936113e-08, .2564861e-11, -.3704404e-13 /) + real(kind=4), dimension(0:8), parameter :: cll = (/ .6105851e+03, .4440316e+02 & + , .1430341e+01, .2641412e-01 & + , .2995057e-03, .2031998e-05 & + , .6936113e-08, .2564861e-11 & + , -.3704404e-13 /) !----- Coefficients for esat (ice) -----------------------------------------------------! - real, dimension(0:8), parameter :: cii = (/ .6114327e+03, .5027041e+02, .1875982e+01 & - , .4158303e-01, .5992408e-03, .5743775e-05 & - , .3566847e-07, .1306802e-09, .2152144e-12 /) + real(kind=4), dimension(0:8), parameter :: cii = (/ .6114327e+03, .5027041e+02 & + , .1875982e+01, .4158303e-01 & + , .5992408e-03, .5743775e-05 & + , .3566847e-07, .1306802e-09 & + , .2152144e-12 /) !----- Coefficients for d(esat)/dT (liquid) --------------------------------------------! - real, dimension(0:8), parameter :: dll = (/ .4443216e+02, .2861503e+01, .7943347e-01 & - , .1209650e-02, .1036937e-04, .4058663e-07 & - ,-.5805342e-10, -.1159088e-11, -.3189651e-14 /) + real(kind=4), dimension(0:8), parameter :: dll = (/ .4443216e+02, .2861503e+01 & + , .7943347e-01, .1209650e-02 & + , .1036937e-04, .4058663e-07 & + , -.5805342e-10, -.1159088e-11 & + , -.3189651e-14 /) !----- Coefficients for esat (ice) -----------------------------------------------------! - real, dimension(0:8), parameter :: dii = (/ .5036342e+02, .3775758e+01, .1269736e+00 & - , .2503052e-02, .3163761e-04, .2623881e-06 & - , .1392546e-08, .4315126e-11, .5961476e-14 /) - !---------------------------------------------------------------------------------------! - + real(kind=4), dimension(0:8), parameter :: dii = (/ .5036342e+02, .3775758e+01 & + , .1269736e+00, .2503052e-02 & + , .3163761e-04, .2623881e-06 & + , .1392546e-08, .4315126e-11 & + , .5961476e-14 /) + !=======================================================================================! + !=======================================================================================! contains + + + !=======================================================================================! !=======================================================================================! ! This function calculates the liquid saturation vapour pressure as a function of ! ! Kelvin temperature. This expression came from MK05, equation (10). ! !---------------------------------------------------------------------------------------! - real function eslf(temp,l1funout,l2funout,ttfunout) - use rconstants, only : t00 + real(kind=4) function eslf(temp,l1funout,l2funout,ttfunout) + use rconstants , only : t00 ! ! intent(in) implicit none - real, intent(in) :: temp - real, intent(out), optional :: l1funout,ttfunout,l2funout - real :: l1fun,ttfun,l2fun,x + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! + real(kind=4), intent(out), optional :: l1funout ! Function for high temperatures + real(kind=4), intent(out), optional :: ttfunout ! Interpolation function + real(kind=4), intent(out), optional :: l2funout ! Function for low temperatures + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: l1fun ! + real(kind=4) :: ttfun ! + real(kind=4) :: l2fun ! + real(kind=4) :: x ! + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Choose between the old and the new thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then !----- Updated method, using MK05 ------------------------------------------------! l1fun = l01_10(0) + l01_10(1)/temp + l01_10(2)*log(temp) + l01_10(3) * temp l2fun = l02_10(0) + l02_10(1)/temp + l02_10(2)*log(temp) + l02_10(3) * temp ttfun = tanh(ttt_10(1) * (temp - ttt_10(2))) eslf = exp(l1fun + ttfun*l2fun) + !---------------------------------------------------------------------------------! if (present(l1funout)) l1funout = l1fun if (present(l2funout)) l2funout = l2fun @@ -127,6 +156,7 @@ real function eslf(temp,l1funout,l2funout,ttfunout) x = max(-80.,temp-t00) eslf = cll(0) + x * (cll(1) + x * (cll(2) + x * (cll(3) + x * (cll(4) & + x * (cll(5) + x * (cll(6) + x * (cll(7) + x * cll(8)) ) ) ) ) ) ) + !---------------------------------------------------------------------------------! if (present(l1funout)) l1funout = eslf if (present(l2funout)) l2funout = eslf @@ -148,28 +178,42 @@ end function eslf ! This function calculates the ice saturation vapour pressure as a function of ! ! Kelvin temperature, based on MK05 equation (7). ! !---------------------------------------------------------------------------------------! - real function esif(temp,iifunout) - use rconstants, only : t00 + real(kind=4) function esif(temp,iifunout) + use rconstants , only : t00 ! ! intent(in) implicit none - real, intent(in) :: temp - real, intent(out), optional :: iifunout - real :: iifun,x + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! + real(kind=4), intent(out), optional :: iifunout + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: iifun + real(kind=4) :: x + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Choose between the old and the new thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then !----- Updated method, using MK05 ------------------------------------------------! iifun = iii_7(0) + iii_7(1)/temp + iii_7(2) * log(temp) + iii_7(3) * temp esif = exp(iifun) - + !---------------------------------------------------------------------------------! + + if (present(iifunout)) iifunout=iifun else !----- Original method, using polynomial fit (FWC92) -----------------------------! x=max(-80.,temp-t00) esif = cii(0) + x * (cii(1) + x * (cii(2) + x * (cii(3) + x * (cii(4) & + x * (cii(5) + x * (cii(6) + x * (cii(7) + x * cii(8)) ) ) ) ) ) ) + !---------------------------------------------------------------------------------! if (present(iifunout)) iifunout=esif end if + !------------------------------------------------------------------------------------! + return end function esif !=======================================================================================! @@ -186,24 +230,44 @@ end function esif ! temperature. It chooses which phase to look depending on whether the temperature is ! ! below or above the triple point. ! !---------------------------------------------------------------------------------------! - real function eslif(temp,useice) - use rconstants, only: t3ple + real(kind=4) function eslif(temp,useice) + use rconstants , only : t3ple ! ! intent(in) implicit none - real , intent(in) :: temp - logical, intent(in), optional :: useice - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice + !----- Local variables. -------------------------------------------------------------! + logical :: frozen + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple end if + !------------------------------------------------------------------------------------! + - if (brrr_cold) then - eslif = esif(temp) ! Ice saturation vapour pressure + + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- Saturation vapour pressure for ice. ---------------------------------------! + eslif = esif(temp) + !---------------------------------------------------------------------------------! else - eslif = eslf(temp) ! Liquid saturation vapour pressure + !----- Saturation vapour pressure for liquid. ------------------------------------! + eslif = eslf(temp) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return end function eslif @@ -220,14 +284,29 @@ end function eslif ! This function calculates the liquid saturation vapour mixing ratio as a function ! ! of pressure and Kelvin temperature. ! !---------------------------------------------------------------------------------------! - real function rslf(pres,temp) - use rconstants, only : ep,toodry + real(kind=4) function rslf(pres,temp) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real, intent(in) :: pres,temp - real :: esl + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esl ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + !----- First we find the saturation vapour pressure. --------------------------------! esl = eslf(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the mixing ! + ! ratio. ! + !------------------------------------------------------------------------------------! rslf = max(toodry,ep*esl/(pres-esl)) + !------------------------------------------------------------------------------------! return end function rslf @@ -244,14 +323,29 @@ end function rslf ! This function calculates the ice saturation vapour mixing ratio as a function of ! ! pressure and Kelvin temperature. ! !---------------------------------------------------------------------------------------! - real function rsif(pres,temp) - use rconstants, only : ep,toodry + real(kind=4) function rsif(pres,temp) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real, intent(in) :: pres,temp - real :: esi + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esi ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + !----- First we find the saturation vapour pressure. --------------------------------! esi = esif(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the mixing ! + ! ratio. ! + !------------------------------------------------------------------------------------! rsif = max(toodry,ep*esi/(pres-esi)) + !------------------------------------------------------------------------------------! return end function rsif @@ -268,29 +362,55 @@ end function rsif ! This function calculates the saturation vapour mixing ratio, over liquid or ice ! ! depending on temperature, as a function of pressure and Kelvin temperature. ! !---------------------------------------------------------------------------------------! - real function rslif(pres,temp,useice) - use rconstants, only: t3ple,ep + real(kind=4) function rslif(pres,temp,useice) + use rconstants , only : t3ple & ! intent(in) + , ep ! ! intent(in) implicit none - real , intent(in) :: pres,temp - logical, intent(in), optional :: useice - real :: esz - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: pres + real(kind=4), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esz + logical :: frozen + !------------------------------------------------------------------------------------! - !----- Checking which saturation (liquid or ice) I should use here ------------------! + + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple end if + !------------------------------------------------------------------------------------! + - !----- Finding the saturation vapour pressure ---------------------------------------! - if (brrr_cold) then + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- Saturation vapour pressure for ice. ---------------------------------------! esz = esif(temp) + !---------------------------------------------------------------------------------! else + !----- Saturation vapour pressure for liquid. ------------------------------------! esz = eslf(temp) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the mixing ! + ! ratio. ! + !------------------------------------------------------------------------------------! rslif = ep * esz / (pres - esz) + !------------------------------------------------------------------------------------! return end function rslif @@ -302,19 +422,179 @@ end function rslif + !=======================================================================================! + !=======================================================================================! + ! This function calculates the liquid saturation specific humidity as a function of ! + ! pressure and Kelvin temperature. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function qslf(pres,temp) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esl ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- First we find the saturation vapour pressure. --------------------------------! + esl = eslf(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the ! + ! specific humidity. ! + !------------------------------------------------------------------------------------! + qslf = max(toodry,ep * esl/( pres - (1.0 - ep) * esl) ) + !------------------------------------------------------------------------------------! + + return + end function qslf + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function calculates the ice saturation specific humidity as a function of ! + ! pressure and Kelvin temperature. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function qsif(pres,temp) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esi ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- First we find the saturation vapour pressure. --------------------------------! + esi = esif(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the ! + ! specific humidity. ! + !------------------------------------------------------------------------------------! + qsif = max(toodry,ep * esi/( pres - (1.0 - ep) * esi) ) + !------------------------------------------------------------------------------------! + + return + end function qsif + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function calculates the saturation specific humidity, over liquid or ice ! + ! depending on temperature, as a function of pressure and Kelvin temperature. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function qslif(pres,temp,useice) + use rconstants , only : t3ple & ! intent(in) + , ep & ! intent(in) + , toodry ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: pres + real(kind=4), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esz + logical :: frozen + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! + if (present(useice)) then + frozen = useice .and. temp < t3ple + else + frozen = bulk_on .and. temp < t3ple + end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- Saturation vapour pressure for ice. ---------------------------------------! + esz = esif(temp) + !---------------------------------------------------------------------------------! + else + !----- Saturation vapour pressure for liquid. ------------------------------------! + esz = eslf(temp) + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the ! + ! specific humidity. ! + !------------------------------------------------------------------------------------! + qslif = max(toodry, ep * esz/( pres - (1.0 - ep) * esz) ) + !------------------------------------------------------------------------------------! + + return + end function qslif + !=======================================================================================! + !=======================================================================================! + + + + + + !=======================================================================================! !=======================================================================================! ! This function calculates the vapour-liquid equilibrium density for vapour, as a ! ! function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! - real function rhovsl(temp) - use rconstants, only : rh2o + real(kind=4) function rhovsl(temp) + use rconstants , only : rh2o ! ! intent(in) implicit none - real, intent(in) :: temp - real :: eequ + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: eequ ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the equilibrium (saturation) vapour pressure. ! + !------------------------------------------------------------------------------------! eequ = eslf(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the saturation density. ! + !------------------------------------------------------------------------------------! rhovsl = eequ / (rh2o * temp) + !------------------------------------------------------------------------------------! + return end function rhovsl !=======================================================================================! @@ -331,13 +611,29 @@ end function rhovsl ! This function calculates the vapour-ice equilibrium density for vapour, as a ! ! function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! - real function rhovsi(temp) - use rconstants, only : rh2o + real(kind=4) function rhovsi(temp) + use rconstants , only : rh2o ! ! intent(in) implicit none - real, intent(in) :: temp - real :: eequ + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: eequ ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the equilibrium (saturation) vapour pressure. ! + !------------------------------------------------------------------------------------! eequ = esif(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the saturation density. ! + !------------------------------------------------------------------------------------! rhovsi = eequ / (rh2o * temp) + !------------------------------------------------------------------------------------! + return end function rhovsi !=======================================================================================! @@ -348,27 +644,42 @@ end function rhovsi - !=======================================================================================! !=======================================================================================! ! This function calculates the saturation density for vapour, as a function of tem- ! ! perature in Kelvin. It will decide between ice-vapour or liquid-vapour based on the ! ! temperature. ! !---------------------------------------------------------------------------------------! - real function rhovsil(temp,useice) - use rconstants, only : rh2o + real(kind=4) function rhovsil(temp,useice) + use rconstants , only : rh2o ! ! intent(in) implicit none - real, intent(in) :: temp - logical, intent(in), optional :: useice - real :: eequ + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: eequ + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Pass the "useice" argument to eslif, so it may decide whether ice thermo- ! + ! dynamics is to be used. ! + !------------------------------------------------------------------------------------! if (present(useice)) then eequ = eslif(temp,useice) else eequ = eslif(temp) end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the saturation density. ! + !------------------------------------------------------------------------------------! rhovsil = eequ / (rh2o * temp) + !------------------------------------------------------------------------------------! return end function rhovsil @@ -385,25 +696,40 @@ end function rhovsil ! This function calculates the partial derivative of liquid saturation vapour ! ! pressure with respect to temperature as a function of Kelvin temperature. ! !---------------------------------------------------------------------------------------! - real function eslfp(temp) - use rconstants, only: t00 + real(kind=4) function eslfp(temp) + use rconstants , only : t00 ! ! intent(in) implicit none - real, intent(in) :: temp - real :: esl,l2fun,ttfun,l1prime,l2prime,ttprime,x + !------ Arguments. ------------------------------------------------------------------! + real(kind=4), intent(in) :: temp + !------ Local variables. ------------------------------------------------------------! + real(kind=4) :: esl + real(kind=4) :: l2fun + real(kind=4) :: ttfun + real(kind=4) :: l1prime + real(kind=4) :: l2prime + real(kind=4) :: ttprime + real(kind=4) :: x + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide which function to use, based on the thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then !----- Updated method, using MK05 ------------------------------------------------! - esl = eslf(temp,l2funout=l2fun,ttfunout=ttfun) + esl = eslf(temp,l2funout=l2fun,ttfunout=ttfun) l1prime = -l01_10(1)/(temp*temp) + l01_10(2)/temp + l01_10(3) l2prime = -l02_10(1)/(temp*temp) + l02_10(2)/temp + l02_10(3) ttprime = ttt_10(1)*(1.-ttfun*ttfun) - eslfp = esl * (l1prime + l2prime*ttfun + l2fun*ttprime) + eslfp = esl * (l1prime + l2prime*ttfun + l2fun*ttprime) else !----- Original method, using polynomial fit (FWC92) -----------------------------! - x=max(-80.,temp-t00) + x = max(-80.,temp-t00) eslfp = dll(0) + x * (dll(1) + x * (dll(2) + x * (dll(3) + x * (dll(4) & + x * (dll(5) + x * (dll(6) + x * (dll(7) + x * dll(8)) ) ) ) ) ) ) end if + !------------------------------------------------------------------------------------! return @@ -421,12 +747,22 @@ end function eslfp ! This function calculates the partial derivative of ice saturation vapour pressure ! ! with respect to temperature as a function of Kelvin temperature. ! !---------------------------------------------------------------------------------------! - real function esifp(temp) - use rconstants, only: lsorvap, t00 + real(kind=4) function esifp(temp) + use rconstants , only : t00 ! ! intent(in) implicit none - real, intent(in) :: temp - real :: esi,iiprime,x + !------ Arguments. ------------------------------------------------------------------! + real(kind=4), intent(in) :: temp + !------ Local variables. ------------------------------------------------------------! + real(kind=4) :: esi + real(kind=4) :: iiprime + real(kind=4) :: x + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide which function to use, based on the thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then !----- Updated method, using MK05 ------------------------------------------------! esi = esif(temp) @@ -438,6 +774,7 @@ real function esifp(temp) esifp = dii(0) + x * (dii(1) + x * (dii(2) + x * (dii(3) + x * (dii(4) & + x * (dii(5) + x * (dii(6) + x * (dii(7) + x * dii(8)) ) ) ) ) ) ) end if + !------------------------------------------------------------------------------------! return end function esifp @@ -455,24 +792,44 @@ end function esifp ! a function of Kelvin temperature. It chooses which phase to look depending on ! ! whether the temperature is below or above the triple point. ! !---------------------------------------------------------------------------------------! - real function eslifp(temp,useice) - use rconstants, only: t3ple + real(kind=4) function eslifp(temp,useice) + use rconstants , only : t3ple ! ! intent(in) implicit none - real , intent(in) :: temp - logical, intent(in), optional :: useice - logical :: brrr_cold + !------ Arguments. ------------------------------------------------------------------! + real(kind=4), intent(in) :: temp + !------ Local variables. ------------------------------------------------------------! + logical , intent(in), optional :: useice + logical :: frozen + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple end if + !------------------------------------------------------------------------------------! + + - if (brrr_cold) then - eslifp = esifp(temp) ! d(Ice saturation vapour pressure)/dT + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- d(Saturation vapour pressure)/dT for ice. ---------------------------------! + eslifp = esifp(temp) + !---------------------------------------------------------------------------------! else - eslifp = eslfp(temp) ! d(Liquid saturation vapour pressure)/dT + !----- d(Saturation vapour pressure)/dT for liquid water. ------------------------! + eslifp = eslfp(temp) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return end function eslifp @@ -491,17 +848,37 @@ end function eslifp ! ing ratio with respect to temperature as a function of pressure and Kelvin tempera- ! ! ture. ! !---------------------------------------------------------------------------------------! - real function rslfp(pres,temp) - use rconstants, only: ep + real(kind=4) function rslfp(pres,temp) + use rconstants , only : ep ! ! intent(in) implicit none - real, intent(in) :: pres,temp - real :: desdt,esl,pdry + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esl ! Partial pressure [ Pa] + real(kind=4) :: desdt ! Derivative of partial pressure of water [ Pa/K] + real(kind=4) :: pdry ! Partial pressure of dry air [ Pa] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! esl = eslf(temp) desdt = eslfp(temp) - + !------------------------------------------------------------------------------------! + + + !----- Find the partial pressure of dry air. ----------------------------------------! pdry = pres-esl + !------------------------------------------------------------------------------------! + + + !----- Find the partial derivative of mixing ratio. ---------------------------------! rslfp = ep * pres * desdt / (pdry*pdry) + !------------------------------------------------------------------------------------! return end function rslfp @@ -520,18 +897,36 @@ end function rslfp ! ing ratio with respect to temperature as a function of pressure and Kelvin tempera- ! ! ture. ! !---------------------------------------------------------------------------------------! - real function rsifp(pres,temp) - use rconstants, only: ep + real(kind=4) function rsifp(pres,temp) + use rconstants , only : ep ! ! intent(in) implicit none - real, intent(in) :: pres,temp - real :: desdt,esi,pdry + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esi ! Partial pressure [ Pa] + real(kind=4) :: desdt ! Derivative of partial pressure of water [ Pa/K] + real(kind=4) :: pdry ! Partial pressure of dry air [ Pa] + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! esi = esif(temp) desdt = esifp(temp) - - pdry = pres-esi - rsifp = ep * pres * desdt / (pdry*pdry) + !------------------------------------------------------------------------------------! + + !----- Find the partial pressure of dry air. ----------------------------------------! + pdry = pres-esi + !------------------------------------------------------------------------------------! + + + !----- Find the partial derivative of mixing ratio. ---------------------------------! + rsifp = ep * pres * desdt / (pdry*pdry) + !------------------------------------------------------------------------------------! return end function rsifp !=======================================================================================! @@ -549,25 +944,42 @@ end function rsifp ! ing ratio with respect to temperature as a function of pressure and Kelvin tempera- ! ! ture. ! !---------------------------------------------------------------------------------------! - real function rslifp(pres,temp,useice) - use rconstants, only: t3ple + real(kind=4) function rslifp(pres,temp,useice) + use rconstants , only: t3ple ! ! intent(in) implicit none - real , intent(in) :: pres,temp - logical, intent(in), optional :: useice - real :: desdt - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics? [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: desdt ! Derivative of vapour pressure [ Pa/K] + logical :: frozen ! Use the ice thermodynamics [ T|F] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide whether to use liquid water of ice for saturation, based on the temper- ! + ! ature and the settings. ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple end if + !------------------------------------------------------------------------------------! - if (brrr_cold) then - rslifp=rsifp(pres,temp) + + !------------------------------------------------------------------------------------! + ! Call the function depending on the previous check. ! + !------------------------------------------------------------------------------------! + if (frozen) then + rslifp = rsifp(pres,temp) else - rslifp=rslfp(pres,temp) + rslifp = rslfp(pres,temp) end if + !------------------------------------------------------------------------------------! return end function rslifp @@ -585,15 +997,30 @@ end function rslifp ! This function calculates the derivative of vapour-liquid equilibrium density, as ! ! a function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! - real function rhovslp(temp) - use rconstants, only : rh2o + real(kind=4) function rhovslp(temp) + use rconstants , only : rh2o ! ! intent(in) implicit none - real, intent(in) :: temp - real :: es,desdt + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: es ! Vapour pressure [ Pa] + real(kind=4) :: desdt ! Vapour pressure derivative [ Pa/K] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! es = eslf(temp) desdt = eslfp(temp) + !------------------------------------------------------------------------------------! + + + !----- Find the partial derivative of saturation density . --------------------------! rhovslp = (desdt-es/temp) / (rh2o * temp) + !------------------------------------------------------------------------------------! return end function rhovslp @@ -611,15 +1038,30 @@ end function rhovslp ! This function calculates the derivative of vapour-ice equilibrium density, as a ! ! function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! - real function rhovsip(temp) - use rconstants, only : rh2o + real(kind=4) function rhovsip(temp) + use rconstants , only : rh2o ! ! intent(in) implicit none - real, intent(in) :: temp - real :: es,desdt + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: es ! Vapour pressure [ Pa] + real(kind=4) :: desdt ! Vapour pressure derivative [ Pa/K] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! es = esif(temp) desdt = esifp(temp) + !------------------------------------------------------------------------------------! + + + !----- Find the partial derivative of saturation density . --------------------------! rhovsip = (desdt-es/temp) / (rh2o * temp) + !------------------------------------------------------------------------------------! return end function rhovsip @@ -638,24 +1080,40 @@ end function rhovsip ! function of temperature in Kelvin. It will decide between ice-vapour or liquid-vapour ! ! based on the temperature. ! !---------------------------------------------------------------------------------------! - real function rhovsilp(temp,useice) - use rconstants, only: t3ple + real(kind=4) function rhovsilp(temp,useice) + use rconstants , only : t3ple ! ! intent(in) implicit none - real, intent(in) :: temp - logical, intent(in), optional :: useice - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics? [ T|F] + !----- Local variables. -------------------------------------------------------------! + logical :: frozen ! Derivative of vapour pressure [ Pa/K] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide whether to use liquid water of ice for saturation, based on the temper- ! + ! ature and the settings. ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple end if + !------------------------------------------------------------------------------------! + - if (brrr_cold) then - rhovsilp=rhovsip(temp) + !------------------------------------------------------------------------------------! + ! Call the function depending on the previous check. ! + !------------------------------------------------------------------------------------! + if (frozen) then + rhovsilp = rhovsip(temp) else - rhovsilp=rhovslp(temp) + rhovsilp = rhovslp(temp) end if + !------------------------------------------------------------------------------------! return end function rhovsilp @@ -676,81 +1134,120 @@ end function rhovsilp ! the unlikely case in which Newton's method fails, switch back to modified Regula ! ! Falsi method (Illinois). ! !---------------------------------------------------------------------------------------! - real function tslf(pvap) + real(kind=4) function tslf(pvap) - implicit none - !----- Argument ---------------------------------------------------------------------! - real, intent(in) :: pvap ! Saturation vapour pressure [ Pa] - !----- Local variables for iterative method -----------------------------------------! - real :: deriv ! Function derivative [ Pa] - real :: fun ! Function for which we seek a root. [ Pa] - real :: funa ! Smallest guess function [ Pa] - real :: funz ! Largest guess function [ Pa] - real :: tempa ! Smallest guess (or previous guess) [ Pa] - real :: tempz ! Largest guess (or new guess in Newton) [ Pa] - real :: delta ! Aux. var --- 2nd guess for bisection [ ] - integer :: itn,itb ! Iteration counter [ ---] - logical :: converged ! Convergence handle [ ---] - logical :: zside ! Flag to check for one-sided approach... [ ---] - !------------------------------------------------------------------------------------! - - !----- First Guess, using Bolton (1980) equation 11, giving es in Pa and T in K -----! + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pvap ! Saturation vapour pressure [ Pa] + !----- Local variables for iterative method. ----------------------------------------! + real(kind=4) :: deriv ! Function derivative [ Pa] + real(kind=4) :: fun ! Function for which we seek a root. [ Pa] + real(kind=4) :: funa ! Smallest guess function [ Pa] + real(kind=4) :: funz ! Largest guess function [ Pa] + real(kind=4) :: tempa ! Smallest guess (or previous guess) [ Pa] + real(kind=4) :: tempz ! Largest guess (new guess in Newton) [ Pa] + real(kind=4) :: delta ! Aux. var --- 2nd guess for bisection [ ] + integer :: itn ! Iteration counter [ ---] + integer :: itb ! Iteration counter [ ---] + logical :: converged ! Convergence handle [ ---] + logical :: zside ! Flag to check for one-sided approach [ ---] + !------------------------------------------------------------------------------------! + + !----- First Guess, use Bolton (1980) equation 11, giving es in Pa and T in K -------! tempa = (29.65 * log(pvap) - 5016.78)/(log(pvap)-24.0854) funa = eslf(tempa) - pvap deriv = eslfp(tempa) - !----- Copying just in case it fails at the first iteration -------------------------! + !------------------------------------------------------------------------------------! + + + !----- Copy just in case it fails at the first iteration ----------------------------! tempz = tempa fun = funa - + !------------------------------------------------------------------------------------! + + !----- Enter Newton's method loop: --------------------------------------------------! converged = .false. newloop: do itn = 1,maxfpo/6 if (abs(deriv) < toler) exit newloop !----- Too dangerous, go with bisection -----! - !----- Copying the previous guess ------------------------------------------------! + + !----- Copy the previous guess. --------------------------------------------------! tempa = tempz funa = fun - !----- New guess, its function and derivative evaluation -------------------------! + !---------------------------------------------------------------------------------! + + + !----- New guess, its function, and derivative evaluation. -----------------------! tempz = tempa - fun/deriv fun = eslf(tempz) - pvap deriv = eslfp(tempz) - + !---------------------------------------------------------------------------------! + + + !----- Check convergence. --------------------------------------------------------! converged = abs(tempa-tempz) < toler * tempz if (converged) then - tslf = 0.5*(tempa+tempz) + tslf = 0.5 * (tempa+tempz) return - elseif (fun ==0) then !Converged by luck! + elseif (fun == 0.0) then + !----- Converged by luck. -----------------------------------------------------! tslf = tempz return end if + !---------------------------------------------------------------------------------! end do newloop + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! If we have reached this point, then Newton's method has failed. Use bisection ! + ! instead. For bisection, we need two guesses whose function has opposite signs. ! !------------------------------------------------------------------------------------! if (funa * fun < 0.) then + !----- We already have two guesses with opposite signs. --------------------------! funz = fun zside = .true. + !---------------------------------------------------------------------------------! else + !----- Need to find the guesses with opposite signs. -----------------------------! if (abs(fun-funa) < 100.*toler*tempa) then delta = 100.*toler*tempa else delta = max(abs(funa * (tempz-tempa)/(fun-funa)),100.*toler*tempa) end if + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! Try guesses on both sides of the first guess, increasingly further away ! + ! until we spot a good guess. ! + !---------------------------------------------------------------------------------! tempz = tempa + delta zside = .false. zgssloop: do itb=1,maxfpo tempz = tempa + real((-1)**itb * (itb+3)/2) * delta funz = eslf(tempz) - pvap - zside = funa*funz < 0 + zside = funa*funz < 0. if (zside) exit zgssloop end do zgssloop if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempa=',tempa,'funa=',funa - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempz=',tempz,'func=',funz - call abort_run('Failed finding the second guess for regula falsi' & - ,'tslf','therm_lib.f90') + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the second guess:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' + call abort_run ('Failed finding the second guess for regula falsi' & + ,'tslf','therm_lib.f90') end if end if @@ -759,36 +1256,52 @@ real function tslf(pvap) tslf = (funz*tempa-funa*tempz)/(funz-funa) !---------------------------------------------------------------------------------! - ! Now that we updated the guess, check whether they are really close. If so, ! + ! Now that we updated the guess, check whether they are really close. If so, ! ! it converged, I can use this as my guess. ! !---------------------------------------------------------------------------------! converged = abs(tslf-tempa) < toler * tslf if (converged) exit bisloop - !------ Finding the new function -------------------------------------------------! + !------ Find the new function evaluation. ----------------------------------------! fun = eslf(tslf) - pvap + !---------------------------------------------------------------------------------! - !------ Defining my new interval based on the intermediate value theorem. --------! + + !------ Define the new interval based on the intermediate value theorem. ---------! if (fun*funa < 0. ) then tempz = tslf funz = fun - !----- If we are updating zside again, modify aside (Illinois method) ---------! + !----- If we are updating zside again, modify aside (Illinois method). --------! if (zside) funa=funa * 0.5 - !----- We just updated zside, setting zside to true. --------------------------! + !----- We have just updated zside, so we set zside to true. -------------------! zside = .true. else tempa = tslf funa = fun - !----- If we are updating aside again, modify aside (Illinois method) ---------! + !----- If we are updating aside again, modify zside (Illinois method). --------! if (.not. zside) funz=funz * 0.5 - !----- We just updated aside, setting aside to true. --------------------------! + !----- We have just updated aside, so we set zside to false. ------------------! zside = .false. end if end do bisloop if (.not.converged) then - call abort_run('Temperature didn''t converge, giving up!!!' & - ,'tslf','therm_lib.f90') + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the solution:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' + call abort_run ('Temperature didn''t converge, we give up!!!' & + ,'tslf','therm_lib.f90') end if return @@ -809,44 +1322,56 @@ end function tslf ! the unlikely case in which Newton's method fails, switch back to modified Regula ! ! Falsi method (Illinois). ! !---------------------------------------------------------------------------------------! - real function tsif(pvap) + real(kind=4) function tsif(pvap) - implicit none - !----- Argument ---------------------------------------------------------------------! - real, intent(in) :: pvap ! Saturation vapour pressure [ Pa] + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pvap ! Saturation vapour pressure [ Pa] !----- Local variables for iterative method -----------------------------------------! - real :: deriv ! Function derivative [ Pa] - real :: fun ! Function for which we seek a root. [ Pa] - real :: funa ! Smallest guess function [ Pa] - real :: funz ! Largest guess function [ Pa] - real :: tempa ! Smallest guess (or previous guess) [ Pa] - real :: tempz ! Largest guess (or new guess in Newton) [ Pa] - real :: delta ! Aux. var --- 2nd guess for bisection [ ] - integer :: itn,itb ! Iteration counter [ ---] - logical :: converged ! Convergence handle [ ---] - logical :: zside ! Flag to check for one-sided approach... [ ---] - !------------------------------------------------------------------------------------! - - !----- First Guess, using Murphy-Koop (2005), equation 8. ---------------------------! + real(kind=4) :: deriv ! Function derivative [ Pa] + real(kind=4) :: fun ! Function for which we seek a root. [ Pa] + real(kind=4) :: funa ! Smallest guess function [ Pa] + real(kind=4) :: funz ! Largest guess function [ Pa] + real(kind=4) :: tempa ! Smallest guess (or previous guess) [ Pa] + real(kind=4) :: tempz ! Largest guess (new guess in Newton) [ Pa] + real(kind=4) :: delta ! Aux. var --- 2nd guess for bisection [ ] + integer :: itn + integer :: itb ! Iteration counter [ ---] + logical :: converged ! Convergence handle [ ---] + logical :: zside ! Flag to check for one-sided approach [ ---] + !------------------------------------------------------------------------------------! + + !----- First Guess, use Murphy-Koop (2005), equation 8. -----------------------------! tempa = (1.814625 * log(pvap) +6190.134)/(29.120 - log(pvap)) funa = esif(tempa) - pvap deriv = esifp(tempa) - !----- Copying just in case it fails at the first iteration -------------------------! + !------------------------------------------------------------------------------------! + + + !----- Copy just in case it fails at the first iteration ----------------------------! tempz = tempa fun = funa - + !------------------------------------------------------------------------------------! + + !----- Enter Newton's method loop: --------------------------------------------------! converged = .false. newloop: do itn = 1,maxfpo/6 if (abs(deriv) < toler) exit newloop !----- Too dangerous, go with bisection -----! - !----- Copying the previous guess ------------------------------------------------! + + !----- Copy the previous guess. --------------------------------------------------! tempa = tempz funa = fun - !----- New guess, its function and derivative evaluation -------------------------! + + + !----- New guess, its function, and derivative evaluation. -----------------------! tempz = tempa - fun/deriv fun = esif(tempz) - pvap deriv = esifp(tempz) - + !---------------------------------------------------------------------------------! + + + !----- Check convergence. --------------------------------------------------------! converged = abs(tempa-tempz) < toler * tempz if (converged) then tsif = 0.5*(tempa+tempz) @@ -856,34 +1381,58 @@ real function tsif(pvap) return end if end do newloop + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! If we have reached this point, then Newton's method has failed. Use bisection ! + ! instead. For bisection, we need two guesses whose function has opposite signs. ! !------------------------------------------------------------------------------------! if (funa * fun < 0.) then + !----- We already have two guesses with opposite signs. --------------------------! funz = fun zside = .true. + !---------------------------------------------------------------------------------! else + !----- Need to find the guesses with opposite signs. -----------------------------! if (abs(fun-funa) < 100.*toler*tempa) then delta = 100.*toler*delta else delta = max(abs(funa * (tempz-tempa)/(fun-funa)),100.*toler*tempa) end if + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! Try guesses on both sides of the first guess, increasingly further away ! + ! until we spot a good guess. ! + !---------------------------------------------------------------------------------! tempz = tempa + delta zside = .false. zgssloop: do itb=1,maxfpo tempz = tempa + real((-1)**itb * (itb+3)/2) * delta funz = esif(tempz) - pvap - zside = funa*funz < 0 + zside = funa*funz < 0.0 if (zside) exit zgssloop end do zgssloop if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempa=',tempa,'funa=',funa - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempz=',tempz,'func=',funz - call abort_run('Failed finding the second guess for regula falsi' & - ,'tsif','therm_lib.f90') + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the second guess:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' + call abort_run ('Failed finding the second guess for regula falsi' & + ,'tsif','therm_lib.f90') end if end if @@ -892,36 +1441,53 @@ real function tsif(pvap) tsif = (funz*tempa-funa*tempz)/(funz-funa) !---------------------------------------------------------------------------------! - ! Now that we updated the guess, check whether they are really close. If so, ! + ! Now that we updated the guess, check whether they are really close. If so, ! ! it converged, I can use this as my guess. ! !---------------------------------------------------------------------------------! converged = abs(tsif-tempa) < toler * tsif if (converged) exit bisloop + !---------------------------------------------------------------------------------! - !------ Finding the new function -------------------------------------------------! + !------ Find the new function evaluation. ----------------------------------------! fun = esif(tsif) - pvap + !---------------------------------------------------------------------------------! - !------ Defining my new interval based on the intermediate value theorem. --------! + + !------ Define the new interval based on the intermediate value theorem. ---------! if (fun*funa < 0. ) then tempz = tsif funz = fun - !----- If we are updating zside again, modify aside (Illinois method) ---------! + !----- If we are updating zside again, modify aside (Illinois method). --------! if (zside) funa=funa * 0.5 - !----- We just updated zside, setting zside to true. --------------------------! + !----- We have just updated zside, so we set zside to true. -------------------! zside = .true. else tempa = tsif funa = fun - !----- If we are updating aside again, modify aside (Illinois method) ---------! + !----- If we are updating aside again, modify aside (Illinois method). --------! if (.not. zside) funz=funz * 0.5 - !----- We just updated aside, setting aside to true. --------------------------! + !----- We have just updated aside, so we set zside to false. ------------------! zside = .false. end if end do bisloop if (.not.converged) then - call abort_run('Temperature didn''t converge, giving up!!!' & - ,'tsif','therm_lib.f90') + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the solution:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' + call abort_run ('Temperature didn''t converge, we give up!!!' & + ,'tsif','therm_lib.f90') end if return @@ -939,30 +1505,41 @@ end function tsif ! This function calculates the temperature from the ice or liquid mixing ratio. ! ! This is truly the inverse of eslf and esif. ! !---------------------------------------------------------------------------------------! - real function tslif(pvap,useice) - use rconstants, only: es3ple,alvl,alvi + real(kind=4) function tslif(pvap,useice) + use rconstants , only : es3ple ! ! intent(in) implicit none - real , intent(in) :: pvap - logical, intent(in), optional :: useice - logical :: brrr_cold - + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: pvap ! Vapour pressure [ Pa] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] + !----- Local variables. -------------------------------------------------------------! + logical :: frozen ! Will use ice thermodynamics [ T|F] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! - ! Since pvap is a function of temperature only, we can check the triple point ! + ! Since pvap is a function of temperature only, we can check the triple point ! ! from the saturation at the triple point, like what we would do for temperature. ! !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. pvap < es3ple + frozen = useice .and. pvap < es3ple else - brrr_cold = bulk_on .and. pvap < es3ple + frozen = bulk_on .and. pvap < es3ple end if + !------------------------------------------------------------------------------------! - if (brrr_cold) then + !------------------------------------------------------------------------------------! + ! Call the function depending on whether we should use ice. ! + !------------------------------------------------------------------------------------! + if (frozen) then tslif = tsif(pvap) else tslif = tslf(pvap) end if + !------------------------------------------------------------------------------------! return end function tslif @@ -977,19 +1554,34 @@ end function tslif !=======================================================================================! !=======================================================================================! ! This fucntion computes the dew point temperature given the pressure and vapour ! - ! mixing ratio. THIS IS DEWPOINT ONLY, WHICH MEANS THAT IT WILL IGNORE ICE EFFECT. For ! - ! a full, triple-point dependent routine use DEWFROSTPOINT ! + ! mixing ratio. THIS IS DEW POINT ONLY, WHICH MEANS THAT IT WILL IGNORE ICE EFFECT. For ! + ! a full, triple-point dependent routine use DEWFROSTPOINT. ! !---------------------------------------------------------------------------------------! - real function dewpoint(pres,rsat) - use rconstants, only: ep,toodry - + real(kind=4) function dewpoint(pres,rsat) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real, intent(in) :: pres, rsat - real :: rsatoff, pvsat - + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: rsatoff ! Non-singular saturation mixing ratio [ kg/kg] + real(kind=4) :: pvsat ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- Make sure mixing ratio is positive. ------------------------------------------! rsatoff = max(toodry,rsat) - pvsat = pres*rsatoff / (ep + rsatoff) + !------------------------------------------------------------------------------------! + + + !----- Find the saturation vapour pressure. -----------------------------------------! + pvsat = pres * rsatoff / (ep + rsatoff) + !------------------------------------------------------------------------------------! + + !----- Dew point is going to be the saturation temperature. -------------------------! dewpoint = tslf(pvsat) + !------------------------------------------------------------------------------------! return end function dewpoint @@ -1004,19 +1596,34 @@ end function dewpoint !=======================================================================================! !=======================================================================================! ! This fucntion computes the frost point temperature given the pressure and vapour ! - ! mixing ratio. THIS IS FROSTPOINT ONLY, WHICH MEANS THAT IT WILL IGNORE LIQUID EFFECT. ! - ! For a full, triple-point dependent routine use DEWFROSTPOINT ! + ! mixing ratio. THIS IS FROST POINT ONLY, WHICH MEANS THAT IT WILL IGNORE LIQUID ! + ! EFFECT. For a full, triple-point dependent routine use DEWFROSTPOINT. ! !---------------------------------------------------------------------------------------! - real function frostpoint(pres,rsat) - use rconstants, only: ep,toodry - + real(kind=4) function frostpoint(pres,rsat) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real, intent(in) :: pres, rsat - real :: rsatoff, pvsat - + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Local variables for iterative method. ----------------------------------------! + real(kind=4) :: rsatoff ! Non-singular saturation mixing ratio [ kg/kg] + real(kind=4) :: pvsat ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- Make sure mixing ratio is positive. ------------------------------------------! rsatoff = max(toodry,rsat) + !------------------------------------------------------------------------------------! + + + !----- Find the saturation vapour pressure. -----------------------------------------! pvsat = pres*rsatoff / (ep + rsatoff) + !------------------------------------------------------------------------------------! + + !----- Frost point is going to be the saturation temperature. -----------------------! frostpoint = tsif(pvsat) + !------------------------------------------------------------------------------------! return end function frostpoint @@ -1034,21 +1641,37 @@ end function frostpoint ! vapour mixing ratio. This will check whether the vapour pressure is above or below ! ! the triple point vapour pressure, finding dewpoint or frostpoint accordingly. ! !---------------------------------------------------------------------------------------! - real function dewfrostpoint(pres,rsat,useice) - use rconstants, only: ep,toodry + real(kind=4) function dewfrostpoint(pres,rsat,useice) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real , intent(in) :: pres, rsat - logical, intent(in), optional :: useice - real :: rsatoff, pvsat + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: rsatoff ! Non-singular sat. mix. rat. [ kg/kg] + real(kind=4) :: pvsat ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- Make sure mixing ratio is positive. ------------------------------------------! + rsatoff = max(toodry,rsat) + !------------------------------------------------------------------------------------! - rsatoff = max(toodry,rsat) + !----- Find the saturation vapour pressure. -----------------------------------------! pvsat = pres*rsatoff / (ep + rsatoff) + !------------------------------------------------------------------------------------! + + !----- Dew (frost) point is going to be the saturation temperature. -----------------! if (present(useice)) then dewfrostpoint = tslif(pvsat,useice) else dewfrostpoint = tslif(pvsat) end if + !------------------------------------------------------------------------------------! return end function dewfrostpoint !=======================================================================================! @@ -1061,28 +1684,52 @@ end function dewfrostpoint !=======================================================================================! !=======================================================================================! - ! This function computes the vapour mixing ratio based on the pressure [Pa], tem- ! - ! perature [K] and relative humidity [fraction]. IT ALWAYS ASSUME THAT RELATIVE HUMI- ! - ! DITY IS WITH RESPECT TO THE LIQUID PHASE. ptrh2rvapil checks which one to use ! - ! depending on whether temperature is more or less than the triple point. ! + ! This function computes the vapour mixing ratio (or specific humidity) based on ! + ! the pressure [Pa], temperature [K] and relative humidity [fraction]. IT ALWAYS ! + ! ASSUMES THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE LIQUID PHASE. Ptrh2rvapil ! + ! checks which one to use depending on whether temperature is more or less than the ! + ! triple point. ! !---------------------------------------------------------------------------------------! - real function ptrh2rvapl(relh,pres,temp) - use rconstants, only: ep,toodry - + real(kind=4) function ptrh2rvapl(relh,pres,temp,out_shv) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real , intent(in) :: relh, pres, temp - real :: rsath, relhh - rsath = max(toodry,rslf(pres,temp)) + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: relh ! Relative humidity [ --] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + logical , intent(in) :: out_shv ! Output is specific humidity [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: pvap ! Vapour pressure [ Pa] + real(kind=4) :: relhh ! Bounded relative humidity [ --] + !------------------------------------------------------------------------------------! + + + + !---- Make sure relative humidity is bounded. ---------------------------------------! relhh = min(1.,max(0.,relh)) + !------------------------------------------------------------------------------------! - if (newthermo) then - !----- Considering that Rel.Hum. is based on vapour pressure ---------------------! - ptrh2rvapl = max(toodry,ep * relhh * rsath / (ep + (1.-relhh)*rsath)) + + !---- Find the vapour pressure. -----------------------------------------------------! + pvap = relhh * eslf(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Convert the output to the sought humidity variable. ! + !------------------------------------------------------------------------------------! + if (out_shv) then + !----- Specific humidity. --------------------------------------------------------! + ptrh2rvapl = max(toodry, ep * pvap / (pres - (1.0 - ep) * pvap)) + !---------------------------------------------------------------------------------! else - !----- Original RAMS way to compute mixing ratio ---------------------------------! - ptrh2rvapl = max(toodry,relhh*rsath) + !----- Mixing ratio. -------------------------------------------------------------! + ptrh2rvapl = max(toodry, ep * pvap / (pres - pvap)) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return end function ptrh2rvapl @@ -1096,28 +1743,52 @@ end function ptrh2rvapl !=======================================================================================! !=======================================================================================! - ! This function computes the vapour mixing ratio based on the pressure [Pa], tem- ! - ! perature [K] and relative humidity [fraction]. IT ALWAYS ASSUME THAT RELATIVE HUMI- ! - ! DITY IS WITH RESPECT TO THE ICE PHASE. ptrh2rvapil checks which one to use depending ! - ! on whether temperature is more or less than the triple point. ! + ! This function computes the vapour mixing ratio (or specific humidity) based on ! + ! the pressure [Pa], temperature [K] and relative humidity [fraction]. IT ALWAYS ! + ! ASSUMES THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE ICE PHASE. Ptrh2rvapil ! + ! checks which one to use depending on whether temperature is more or less than the ! + ! triple point. ! !---------------------------------------------------------------------------------------! - real function ptrh2rvapi(relh,pres,temp) - use rconstants, only: ep,toodry - + real(kind=4) function ptrh2rvapi(relh,pres,temp,out_shv) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real , intent(in) :: relh, pres, temp - real :: rsath, relhh - rsath = max(toodry,rsif(pres,temp)) + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: relh ! Relative humidity [ --] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + logical , intent(in) :: out_shv ! Output is specific humidity [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: pvap ! Vapour pressure [ Pa] + real(kind=4) :: relhh ! Bounded relative humidity [ --] + !------------------------------------------------------------------------------------! + + + + !---- Make sure relative humidity is bounded. ---------------------------------------! relhh = min(1.,max(0.,relh)) + !------------------------------------------------------------------------------------! - if (newthermo) then - !----- Considering that Rel.Hum. is based on vapour pressure ---------------------! - ptrh2rvapi = max(toodry,ep * relhh * rsath / (ep + (1.-relhh)*rsath)) + + !---- Find the vapour pressure. -----------------------------------------------------! + pvap = relhh * esif(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Convert the output to the sought humidity variable. ! + !------------------------------------------------------------------------------------! + if (out_shv) then + !----- Specific humidity. --------------------------------------------------------! + ptrh2rvapi = max(toodry, ep * pvap / (pres - (1.0 - ep) * pvap)) + !---------------------------------------------------------------------------------! else - !----- Original RAMS way to compute mixing ratio ---------------------------------! - ptrh2rvapi = max(toodry,relhh*rsath) + !----- Mixing ratio. -------------------------------------------------------------! + ptrh2rvapi = max(toodry, ep * pvap / (pres - pvap)) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return end function ptrh2rvapi @@ -1131,36 +1802,67 @@ end function ptrh2rvapi !=======================================================================================! !=======================================================================================! - ! This function computes the vapour mixing ratio based on the pressure [Pa], tem- ! - ! perature [K] and relative humidity [fraction]. It will check the temperature to ! - ! decide between ice or liquid saturation and whether ice should be considered. ! + ! This function computes the vapour mixing ratio based (or specific humidity) based ! + ! on the pressure [Pa], temperature [K] and relative humidity [fraction]. It checks ! + ! the temperature to decide between ice or liquid saturation. ! !---------------------------------------------------------------------------------------! - real function ptrh2rvapil(relh,pres,temp,useice) - use rconstants, only: ep,toodry,t3ple + real(kind=4) function ptrh2rvapil(relh,pres,temp,out_shv,useice) + use rconstants , only : ep & ! intent(in) + , toodry & ! intent(in) + , t3ple ! ! intent(in) implicit none - real , intent(in) :: relh, pres, temp - logical, intent(in), optional :: useice - real :: rsath, relhh - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: relh ! Relative humidity [ --] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + logical , intent(in) :: out_shv ! Output is specific humidity [ T|F] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: pvap ! Vapour pressure [ Pa] + real(kind=4) :: relhh ! Bounded relative humidity [ --] + logical :: frozen ! Will use ice thermodynamics [ T|F] + !------------------------------------------------------------------------------------! + - !----- Checking whether I use the user or the default check for ice saturation. -----! + !----- Check whether to use the user's or the default flag for ice saturation. ------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple end if + !------------------------------------------------------------------------------------! + - if (brrr_cold) then - rsath = max(toodry,rsif(pres,temp)) + + !---- Make sure relative humidity is bounded. ---------------------------------------! + relhh = min(1.,max(0.,relh)) + !------------------------------------------------------------------------------------! + + + !---- Find the vapour pressure (ice or liquid, depending on the value of frozen). ---! + if (frozen) then + pvap = relhh * esif(temp) else - rsath = max(toodry,rslf(pres,temp)) + pvap = relhh * eslf(temp) end if + !------------------------------------------------------------------------------------! - relhh = min(1.,max(0.,relh)) - - ptrh2rvapil = max(toodry,ep * relhh * rsath / (ep + (1.-relhh)*rsath)) + !------------------------------------------------------------------------------------! + ! Convert the output to the sought humidity variable. ! + !------------------------------------------------------------------------------------! + if (out_shv) then + !----- Specific humidity. --------------------------------------------------------! + ptrh2rvapil = max(toodry, ep * pvap / (pres - (1.0 - ep) * pvap)) + !---------------------------------------------------------------------------------! + else + !----- Mixing ratio. -------------------------------------------------------------! + ptrh2rvapil = max(toodry, ep * pvap / (pres - pvap)) + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! return end function ptrh2rvapil !=======================================================================================! @@ -1174,32 +1876,51 @@ end function ptrh2rvapil !=======================================================================================! !=======================================================================================! ! This function computes the relative humidity [fraction] based on pressure, tem- ! - ! perature, and vapour mixing ratio. Two important points: ! + ! perature, and vapour mixing ratio (or specific humidity). Two important points: ! ! 1. IT ALWAYS ASSUME THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE LIQUID PHASE. ! ! If you want to switch between ice and liquid, use rehuil instead. ! ! 2. IT DOESN'T PREVENT SUPERSATURATION TO OCCUR. This is because this subroutine is ! ! also used in the microphysics, where supersaturation does happen and needs to be ! ! accounted. ! !---------------------------------------------------------------------------------------! - real function rehul(pres,temp,rvap) - use rconstants, only: ep,toodry + real(kind=4) function rehul(pres,temp,humi,is_shv) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: pres ! Air pressure [ Pa] - real , intent(in) :: temp ! Temperature [ K] - real , intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] + real(kind=4), intent(in) :: pres ! Air pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: humi ! Humidity [ kg/kg] + logical , intent(in) :: is_shv ! Input humidity is specific humidity [ T|F] !----- Local variables --------------------------------------------------------------! - real :: rvapsat ! Saturation mixing ratio [ kg/kg] + real(kind=4) :: shv ! Specific humidity [ kg/kg] + real(kind=4) :: pvap ! Vapour pressure [ Pa] + real(kind=4) :: psat ! Saturation vapour pressure [ Pa] !------------------------------------------------------------------------------------! - rvapsat = max(toodry,rslf(pres,temp)) - if (newthermo) then - !----- This is based on relative humidity being defined with vapour pressure -----! - rehul = max(0.,rvap*(ep+rvapsat)/(rvapsat*(ep+rvap))) + + !---- Make sure that we have specific humidity. -------------------------------------! + if (is_shv) then + shv = max(toodry,humi) else - !----- Original formula used by RAMS ---------------------------------------------! - rehul = max(0.,rvap/rvapsat) + shv = max(toodry,humi) / ( 1.0 + max(toodry,humi) ) end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the vapour pressure and the saturation vapour pressure. ! + !------------------------------------------------------------------------------------! + pvap = ( pres * shv ) / ( ep + (1.0 - ep) * shv ) + psat = eslf (temp) + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Find the relative humidity. ! + !------------------------------------------------------------------------------------! + rehul = max(0. ,pvap / psat) + !------------------------------------------------------------------------------------! + return end function rehul !=======================================================================================! @@ -1213,38 +1934,57 @@ end function rehul !=======================================================================================! !=======================================================================================! ! This function computes the relative humidity [fraction] based on pressure, tem- ! - ! perature, and vapour mixing ratio. Two important points: ! + ! perature, and vapour mixing ratio (or specific humidity). Two important points: ! ! 1. IT ALWAYS ASSUME THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE ICE PHASE. ! ! If you want to switch between ice and liquid, use rehuil instead. ! ! 2. IT DOESN'T PREVENT SUPERSATURATION TO OCCUR. This is because this subroutine is ! ! also used in the microphysics, where supersaturation does happen and needs to be ! ! accounted. ! !---------------------------------------------------------------------------------------! - real function rehui(pres,temp,rvap) - use rconstants, only: ep,toodry + real(kind=4) function rehui(pres,temp,humi,is_shv) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: pres ! Air pressure [ Pa] - real , intent(in) :: temp ! Temperature [ K] - real , intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] + real(kind=4), intent(in) :: pres ! Air pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: humi ! Humidity [ kg/kg] + logical , intent(in) :: is_shv ! Input humidity is specific humidity [ T|F] !----- Local variables --------------------------------------------------------------! - real :: rvapsat ! Saturation mixing ratio [ kg/kg] + real(kind=4) :: shv ! Specific humidity [ kg/kg] + real(kind=4) :: pvap ! Vapour pressure [ Pa] + real(kind=4) :: psat ! Saturation vapour pressure [ Pa] !------------------------------------------------------------------------------------! - rvapsat = max(toodry,rsif(pres,temp)) - if (newthermo) then - !----- This is based on relative humidity being defined with vapour pressure -----! - rehui = max(0.,rvap*(ep+rvapsat)/(rvapsat*(ep+rvap))) + + !---- Make sure that we have specific humidity. -------------------------------------! + if (is_shv) then + shv = max(toodry,humi) else - !----- Original formula used by RAMS ---------------------------------------------! - rehui = max(0.,rvap/rvapsat) + shv = max(toodry,humi) / ( 1.0 + max(toodry,humi) ) end if - return - end function rehui - !=======================================================================================! - !=======================================================================================! - - + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the vapour pressure and the saturation vapour pressure. ! + !------------------------------------------------------------------------------------! + pvap = ( pres * shv ) / ( ep + (1.0 - ep) * shv ) + psat = esif (temp) + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Find the relative humidity. ! + !------------------------------------------------------------------------------------! + rehui = max(0. ,pvap / psat) + !------------------------------------------------------------------------------------! + + return + end function rehui + !=======================================================================================! + !=======================================================================================! + + @@ -1252,7 +1992,7 @@ end function rehui !=======================================================================================! !=======================================================================================! ! This function computes the relative humidity [fraction] based on pressure, tem- ! - ! perature, and vapour mixing ratio. Two important points: ! + ! perature, and vapour mixing ratio (or specific humidity). Two important points: ! ! 1. It may consider whether the temperature is above or below the freezing point ! ! to choose which saturation to use. It is possible to explicitly force not to use ! ! ice in case level is 2 or if you have reasons not to use ice (e.g. reading data ! @@ -1261,33 +2001,62 @@ end function rehui ! also used in the microphysics, where supersaturation does happen and needs to be ! ! accounted. ! !---------------------------------------------------------------------------------------! - real function rehuil(pres,temp,rvap,useice) - use rconstants, only: t3ple + real(kind=4) function rehuil(pres,temp,humi,is_shv,useice) + use rconstants , only : t3ple & ! intent(in) + , ep & ! intent(in) + , toodry ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: pres ! Air pressure [ Pa] - real , intent(in) :: temp ! Temperature [ K] - real , intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] - logical, intent(in), optional :: useice ! Should I consider ice? [ T|F] + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Air pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: humi ! Humidity [ kg/kg] + logical , intent(in) :: is_shv ! Input is specific humidity [ T|F] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] !----- Local variables --------------------------------------------------------------! - real :: rvapsat ! Saturation mixing ratio [ kg/kg] - logical :: brrr_cold ! I will use ice saturation now [ T|F] + real(kind=4) :: shv ! Specific humidity [ kg/kg] + real(kind=4) :: pvap ! Vapour pressure [ Pa] + real(kind=4) :: psat ! Saturation vapour pressure [ Pa] + logical :: frozen ! Will use ice saturation now [ T|F] !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! - ! Checking whether I should go with ice or liquid saturation. ! + ! Check whether we should use ice or liquid saturation. ! !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple + end if + !------------------------------------------------------------------------------------! + + + !---- Make sure that we have specific humidity. -------------------------------------! + if (is_shv) then + shv = max(toodry,humi) + else + shv = max(toodry,humi) / ( 1.0 + max(toodry,humi) ) end if + !------------------------------------------------------------------------------------! + - if (brrr_cold) then - rehuil = rehui(pres,temp,rvap) + !------------------------------------------------------------------------------------! + ! Find the vapour pressure and the saturation vapour pressure. ! + !------------------------------------------------------------------------------------! + pvap = ( pres * shv ) / ( ep + (1.0 - ep) * shv ) + if (frozen) then + psat = esif (temp) else - rehuil = rehul(pres,temp,rvap) + psat = esif (temp) end if + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Find the relative humidity. ! + !------------------------------------------------------------------------------------! + rehuil = max(0. ,pvap / psat) + !------------------------------------------------------------------------------------! return end function rehuil @@ -1307,23 +2076,33 @@ end function rehuil ! 2. This can be used for virtual potential temperature, just give potential tempera- ! ! ture instead of temperature. ! !---------------------------------------------------------------------------------------! - real function tv2temp(tvir,rvap,rtot) - use rconstants, only: epi + real(kind=4) function tv2temp(tvir,rvap,rtot) + use rconstants , only : epi ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: tvir ! Virtual temperature [ K] - real, intent(in) :: rvap ! Vapour mixing ratio [kg/kg] - real, intent(in), optional :: rtot ! Total mixing ratio [kg/kg] - !----- Local variable ---------------------------------------------------------------! - real :: rtothere ! Internal rtot, to deal with optional [kg/kg] + real(kind=4), intent(in) :: tvir ! Virtual temperature [ K] + real(kind=4), intent(in) :: rvap ! Vapour mixing ratio [kg/kg] + real(kind=4), intent(in), optional :: rtot ! Total mixing ratio [kg/kg] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: rtothere ! Total or vapour mixing ratio [kg/kg] + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Prefer using total mixing ratio, but if it isn't provided, then use vapour ! + ! as total (no condensation). ! + !------------------------------------------------------------------------------------! if (present(rtot)) then rtothere = rtot else rtothere = rvap end if + !------------------------------------------------------------------------------------! + + !----- Convert using a generalised function. ----------------------------------------! tv2temp = tvir * (1. + rtothere) / (1. + epi*rvap) + !------------------------------------------------------------------------------------! return end function tv2temp @@ -1343,23 +2122,33 @@ end function tv2temp ! 2. This can be used for virtual potential temperature, just give potential tempera- ! ! ture instead of temperature. ! !---------------------------------------------------------------------------------------! - real function virtt(temp,rvap,rtot) - use rconstants, only: epi + real(kind=4) function virtt(temp,rvap,rtot) + use rconstants , only: epi ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: rvap ! Vapour mixing ratio [kg/kg] - real, intent(in), optional :: rtot ! Total mixing ratio [kg/kg] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rvap ! Vapour mixing ratio [kg/kg] + real(kind=4), intent(in), optional :: rtot ! Total mixing ratio [kg/kg] !----- Local variable ---------------------------------------------------------------! - real :: rtothere ! Internal rtot, to deal with optional [kg/kg] + real(kind=4) :: rtothere ! Total or vapour mixing ratio [kg/kg] + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Prefer using total mixing ratio, but if it isn't provided, then use vapour ! + ! as total (no condensation). ! + !------------------------------------------------------------------------------------! if (present(rtot)) then rtothere = rtot else rtothere = rvap end if + !------------------------------------------------------------------------------------! + + !----- Convert using a generalised function. ----------------------------------------! virtt = temp * (1. + epi * rvap) / (1. + rtothere) + !------------------------------------------------------------------------------------! return end function virtt @@ -1377,24 +2166,34 @@ end function virtt ! gas law. The condensed phase will be taken into account if the user provided both ! ! the vapour and the total mixing ratios. ! !---------------------------------------------------------------------------------------! - real function idealdens(pres,temp,rvap,rtot) - use rconstants, only: rdry + real(kind=4) function idealdens(pres,temp,rvap,rtot) + use rconstants , only : rdry ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: rvap ! Vapour mixing ratio [kg/kg] - real, intent(in), optional :: rtot ! Total mixing ratio [kg/kg] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] + real(kind=4), intent(in), optional :: rtot ! Total mixing ratio [ kg/kg] !----- Local variable ---------------------------------------------------------------! - real :: tvir ! Virtual temperature [ K] + real(kind=4) :: tvir ! Virtual temperature [ K] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Prefer using total mixing ratio, but if it isn't provided, then use vapour ! + ! as total (no condensation). ! !------------------------------------------------------------------------------------! if (present(rtot)) then tvir = virtt(temp,rvap,rtot) else tvir = virtt(temp,rvap) end if + !------------------------------------------------------------------------------------! + + !----- Convert using the definition of virtual temperature. -------------------------! idealdens = pres / (rdry * tvir) + !------------------------------------------------------------------------------------! return end function idealdens @@ -1412,26 +2211,35 @@ end function idealdens ! gas law. The only difference between this function and the one above is that here we ! ! provide vapour and total specific mass (specific humidity) instead of mixing ratio. ! !---------------------------------------------------------------------------------------! - real function idealdenssh(pres,temp,qvpr,qtot) - use rconstants, only : rdry & ! intent(in) - , epi ! ! intent(in) + real(kind=4) function idealdenssh(pres,temp,qvpr,qtot) + use rconstants , only : rdry & ! intent(in) + , epi ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: qvpr ! Vapour specific mass [kg/kg] - real, intent(in), optional :: qtot ! Total water specific mass [kg/kg] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: qvpr ! Vapour specific mass [ kg/kg] + real(kind=4), intent(in), optional :: qtot ! Total water specific mass [ kg/kg] !----- Local variables. -------------------------------------------------------------! - real :: qall ! Either qtot or qvpr... [kg/kg] + real(kind=4) :: qall ! Either qtot or qvpr... [ kg/kg] !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Prefer using total specific humidity, but if it isn't provided, then use ! + ! vapour phase as the total (no condensation). ! + !------------------------------------------------------------------------------------! if (present(qtot)) then qall = qtot else qall = qvpr end if + !------------------------------------------------------------------------------------! + + !----- Convert using a generalised function. ----------------------------------------! idealdenssh = pres / (rdry * temp * (1. - qall + epi * qvpr)) + !------------------------------------------------------------------------------------! return end function idealdenssh @@ -1446,27 +2254,28 @@ end function idealdenssh !=======================================================================================! !=======================================================================================! ! This function computes reduces the pressure from the reference height to the ! - ! canopy height by assuming hydrostatic equilibrium. ! - !---------------------------------------------------------------------------------------! - real function reducedpress(pres,thetaref,shvref,zref,thetacan,shvcan,zcan) - use rconstants, only : epim1 & ! intent(in) - , p00k & ! intent(in) - , rocp & ! intent(in) - , cpor & ! intent(in) - , cp & ! intent(in) - , grav ! ! intent(in) + ! canopy height by assuming hydrostatic equilibrium. For simplicity, we assume that ! + ! R and cp are constants (in reality they are dependent on humidity). ! + !---------------------------------------------------------------------------------------! + real(kind=4) function reducedpress(pres,thetaref,shvref,zref,thetacan,shvcan,zcan) + use rconstants , only : epim1 & ! intent(in) + , p00k & ! intent(in) + , rocp & ! intent(in) + , cpor & ! intent(in) + , cpdry & ! intent(in) + , grav ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: thetaref ! Potential temperature [ K] - real, intent(in) :: shvref ! Vapour specific mass [ kg/kg] - real, intent(in) :: zref ! Height at reference level [ m] - real, intent(in) :: thetacan ! Potential temperature [ K] - real, intent(in) :: shvcan ! Vapour specific mass [ kg/kg] - real, intent(in) :: zcan ! Height at canopy level [ m] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: thetaref ! Potential temperature [ K] + real(kind=4), intent(in) :: shvref ! Vapour specific mass [ kg/kg] + real(kind=4), intent(in) :: zref ! Height at reference level [ m] + real(kind=4), intent(in) :: thetacan ! Potential temperature [ K] + real(kind=4), intent(in) :: shvcan ! Vapour specific mass [ kg/kg] + real(kind=4), intent(in) :: zcan ! Height at canopy level [ m] !------Local variables. -------------------------------------------------------------! - real :: pinc ! Pressure increment [ Pa^(R/cp)] - real :: thvbar ! Average virtual pot. temper. [ K] + real(kind=4) :: pinc ! Pressure increment [ Pa^R/cp] + real(kind=4) :: thvbar ! Average virtual pot. temperature [ K] !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! @@ -1474,12 +2283,19 @@ real function reducedpress(pres,thetaref,shvref,zref,thetacan,shvcan,zcan) ! top and the reference level. ! !------------------------------------------------------------------------------------! thvbar = 0.5 * (thetaref * (1. + epim1 * shvref) + thetacan * (1. + epim1 * shvcan)) + !------------------------------------------------------------------------------------! + + !----- Then, we find the pressure gradient scale. -----------------------------------! - pinc = grav * p00k * (zref - zcan) / (cp * thvbar) + pinc = grav * p00k * (zref - zcan) / (cpdry * thvbar) + !------------------------------------------------------------------------------------! + + !----- And we can find the reduced pressure. ----------------------------------------! reducedpress = (pres**rocp + pinc ) ** cpor + !------------------------------------------------------------------------------------! return end function reducedpress @@ -1491,50 +2307,31 @@ end function reducedpress + !=======================================================================================! !=======================================================================================! - ! This function computes the enthalpy given the pressure, temperature, vapour ! - ! specific humidity, and height. Currently it doesn't compute mixed phase air, but ! - ! adding it should be straight forward (finding the inverse is another story...). ! + ! This function computes the Exner function [J/kg/K], given the pressure. It ! + ! assumes for simplicity that R and Cp are constants and equal to the dry air values. ! !---------------------------------------------------------------------------------------! - real function ptqz2enthalpy(pres,temp,qvpr,zref) - use rconstants, only : ep & ! intent(in) - , grav & ! intent(in) - , t3ple & ! intent(in) - , eta3ple & ! intent(in) - , cimcp & ! intent(in) - , clmcp & ! intent(in) - , cp & ! intent(in) - , alvi ! ! intent(in) + real(kind=4) function press2exner(pres) + use rconstants , only : p00i & ! intent(in) + , cpdry & ! intent(in) + , rocp ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: qvpr ! Vapour specific mass [ kg/kg] - real, intent(in) :: zref ! Reference height [ m] - !------Local variables. -------------------------------------------------------------! - real :: tequ ! Dew-frost temperature [ K] - real :: pequ ! Equlibrium vapour pressure [ Pa] + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] !------------------------------------------------------------------------------------! - !----- First, we find the equilibrium vapour pressure and dew/frost point. ----------! - pequ = pres * qvpr / (ep + (1. - ep) * qvpr) - tequ = tslif(pequ) !------------------------------------------------------------------------------------! - ! Then, based on dew/frost point, we compute the enthalpy. This accounts whether ! - ! we would have to dew or frost formation if the temperature dropped to the ! - ! equilibrium point. Notice that if supersaturation exists, this will still give a ! - ! number that makes sense, similar to the internal energy of supercooled water. ! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + press2exner = cpdry * ( pres * p00i ) ** rocp !------------------------------------------------------------------------------------! - if (tequ <= t3ple) then - ptqz2enthalpy = cp * temp + qvpr * (cimcp * tequ + alvi ) + grav * zref - else - ptqz2enthalpy = cp * temp + qvpr * (clmcp * tequ + eta3ple) + grav * zref - end if return - end function ptqz2enthalpy + end function press2exner !=======================================================================================! !=======================================================================================! @@ -1543,52 +2340,32 @@ end function ptqz2enthalpy + !=======================================================================================! !=======================================================================================! - ! This function computes the temperature given the enthalpy, pressure, vapour ! - ! specific humidity, and reference height. Currently it doesn't compute mixed phase ! - ! air, but adding it wouldn't be horribly hard, though it would require some root ! - ! finding. ! + ! This function computes the pressure [Pa], given the Exner function. Like in the ! + ! function above, we also assume R and Cp to be constants and equal to the dry air ! + ! values. ! !---------------------------------------------------------------------------------------! - real function hpqz2temp(enthalpy,pres,qvpr,zref) - use rconstants, only : ep & ! intent(in) - , grav & ! intent(in) - , t3ple & ! intent(in) - , eta3ple & ! intent(in) - , cimcp & ! intent(in) - , clmcp & ! intent(in) - , cpi & ! intent(in) - , alvi ! ! intent(in) + real(kind=4) function exner2press(exner) + use rconstants , only : p00 & ! intent(in) + , cpdryi & ! intent(in) + , cpor ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: enthalpy ! Enthalpy... [ J/kg] - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: qvpr ! Vapour specific mass [ kg/kg] - real, intent(in) :: zref ! Reference height [ m] - !------Local variables. -------------------------------------------------------------! - real :: tequ ! Dew-frost temperature [ K] - real :: pequ ! Equlibrium vapour pressure [ Pa] + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: exner ! Exner function [ J/kg/K] !------------------------------------------------------------------------------------! - !----- First, we find the equilibrium vapour pressure and dew/frost point. ----------! - pequ = pres * qvpr / (ep + (1. - ep) * qvpr) - tequ = tslif(pequ) !------------------------------------------------------------------------------------! - ! Then, based on dew/frost point, we compute the temperature. This accounts ! - ! whether we would have to dew or frost formation if the temperature dropped to the ! - ! equilibrium point. Notice that if supersaturation exists, this will still give a ! - ! temperature that makes sense (but less than the dew/frost point), similar to the ! - ! internal energy of supercooled water. ! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + exner2press = p00 * ( exner * cpdryi ) ** cpor !------------------------------------------------------------------------------------! - if (tequ <= t3ple) then - hpqz2temp = cpi * (enthalpy - qvpr * (cimcp * tequ + alvi ) - grav * zref) - else - hpqz2temp = cpi * (enthalpy - qvpr * (clmcp * tequ + eta3ple) - grav * zref) - end if return - end function hpqz2temp + end function exner2press !=======================================================================================! !=======================================================================================! @@ -1597,31 +2374,31 @@ end function hpqz2temp + !=======================================================================================! !=======================================================================================! - ! This function finds the temperature given the potential temperature, density, and ! - ! specific humidity. This comes from a combination of the definition of potential ! - ! temperature and the ideal gas law, to eliminate pressure, when pressure is also ! - ! unknown. ! + ! This function computes the potential temperature [K], given the Exner function ! + ! and temperature. For simplicity we ignore the effects of humidity in R and cp and ! + ! use the dry air values instead. ! !---------------------------------------------------------------------------------------! - real(kind=4) function thrhsh2temp(theta,dens,qvpr) - use rconstants , only : cpocv & ! intent(in) - , p00i & ! intent(in) - , rdry & ! intent(in) - , epim1 & ! intent(in) - , rocv ! ! intent(in) + real(kind=4) function extemp2theta(exner,temp) + use rconstants , only : cpdry ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=4), intent(in) :: theta ! Potential temperature [ K] - real(kind=4), intent(in) :: dens ! Density [ Pa] - real(kind=4), intent(in) :: qvpr ! Specific humidity [ kg/kg] + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: exner ! Exner function [ J/kg/K] + real(kind=4), intent(in) :: temp ! Temperature [ K] !------------------------------------------------------------------------------------! - thrhsh2temp = theta ** cpocv & - * (p00i * dens * rdry * (1. + epim1 * qvpr)) ** rocv + + !------------------------------------------------------------------------------------! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + extemp2theta = cpdry * temp / exner + !------------------------------------------------------------------------------------! return - end function thrhsh2temp + end function extemp2theta !=======================================================================================! !=======================================================================================! @@ -1630,48 +2407,68 @@ end function thrhsh2temp + !=======================================================================================! !=======================================================================================! - ! This fucntion computes the ice liquid potential temperature given the Exner ! - ! function [J/kg/K], temperature [K], and liquid and ice mixing ratios [kg/kg]. ! + ! This function computes the temperature [K], given the Exner function and ! + ! potential temperature. We simplify the equations by assuming that R and Cp are ! + ! constants. ! !---------------------------------------------------------------------------------------! - real function theta_iceliq(exner,temp,rliq,rice) - use rconstants, only: alvl, alvi, cp, ttripoli, htripoli, htripolii + real(kind=4) function extheta2temp(exner,theta) + use rconstants , only : p00i & ! intent(in) + , cpdryi ! ! intent(in) + + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: exner ! Exner function [ J/kg/K] + real(kind=4), intent(in) :: theta ! Potential temperature [ K] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + extheta2temp = cpdryi * exner * theta + !------------------------------------------------------------------------------------! + + return + end function extheta2temp + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the specific (intensive) internal energy of water [J/kg], ! + ! given the temperature and liquid fraction. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function tl2uint(temp,fliq) + use rconstants , only : cice & ! intent(in) + , cliq & ! intent(in) + , tsupercool_liq ! ! intent(in) + implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: exner ! Exner function [J/kg/K] - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] - real, intent(in) :: rice ! Ice mixing ratio [ kg/kg] - !----- Local variables --------------------------------------------------------------! - real :: hh ! Enthalpy associated with sensible heat [ J/kg] - real :: qq ! Enthalpy associated with latent heat [ J/kg] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: fliq ! Fraction liquid water [ kg/kg] !------------------------------------------------------------------------------------! - !----- Finding the enthalpies -------------------------------------------------------! - hh = cp*temp - qq = alvl*rliq+alvi*rice - - if (newthermo) then - - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli) then - theta_iceliq = hh * exp(-qq/hh) / exner - else - theta_iceliq = hh * exp(-qq * htripolii) / exner - end if - else - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli) then - theta_iceliq = hh * hh / (exner * ( hh + qq)) - else - theta_iceliq = hh * htripoli / (exner * ( htripoli + qq)) - end if - end if + + + !------------------------------------------------------------------------------------! + ! Internal energy is given by the sum of internal energies of ice and liquid ! + ! phases. ! + !------------------------------------------------------------------------------------! + tl2uint = (1.0 - fliq) * cice * temp + fliq * cliq * (temp - tsupercool_liq) + !------------------------------------------------------------------------------------! return - end function theta_iceliq + end function tl2uint !=======================================================================================! !=======================================================================================! @@ -1680,82 +2477,94 @@ end function theta_iceliq + !=======================================================================================! !=======================================================================================! - ! This function computes the liquid potential temperature derivative with respect ! - ! to temperature, useful in iterative methods. ! + ! This function computes the extensive internal energy of water [J/m²] or [ J/m³], ! + ! given the temperature [K], the heat capacity of the "dry" part [J/m²/K] or [J/m³/K], ! + ! water mass [ kg/m²] or [ kg/m³], and liquid fraction [---]. ! !---------------------------------------------------------------------------------------! - real function dthetail_dt(condconst,thil,exner,pres,temp,rliq,ricein) - use rconstants, only: alvl, alvi, cp, ttripoli,htripoli,htripolii,t3ple + real(kind=4) function cmtl2uext(dryhcap,wmass,temp,fliq) + use rconstants , only : cice & ! intent(in) + , cliq & ! intent(in) + , tsupercool_liq ! ! intent(in) + + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: dryhcap ! Heat cap. of "dry" part [J/m²/K] or [J/m³/K] + real(kind=4), intent(in) :: wmass ! Water mass [ kg/m²] or [ kg/m³] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: fliq ! Liquid fraction (0-1) [ ---] + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Internal energy is given by the sum of internal energies of dry part, plus the ! + ! contribution of ice and liquid phases. ! + !------------------------------------------------------------------------------------! + cmtl2uext = dryhcap * temp + wmass * ( (1.0 - fliq) * cice * temp & + + fliq * cliq * (temp - tsupercool_liq) ) + !------------------------------------------------------------------------------------! + + return + end function cmtl2uext + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the specific enthalpy [J/kg] given the temperature and ! + ! humidity (either mixing ratio or specific humidity). If we assume that latent heat ! + ! of vaporisation is a linear function of temperature (equivalent to assume that ! + ! specific heats are constants and that the thermal expansion of liquids and solids are ! + ! negligible), then the saturation disappears and the enthalpy becomes a straight- ! + ! forward state function. In case we are accounting for the water exchange only ! + ! (latent heat), set the specific humidity to 1.0 and multiply the result by water mass ! + ! or water flux. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function tq2enthalpy(temp,humi,is_shv) + use rconstants , only : cpdry & ! intent(in) + , cph2o & ! intent(in) + , tsupercool_vap ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - logical, intent(in) :: condconst ! Condensation is constant? [ T|F] - real , intent(in) :: thil ! Ice liquid pot. temperature [ K] - real , intent(in) :: exner ! Exner function [J/kg/K] - real , intent(in) :: pres ! Pressure [ Pa] - real , intent(in) :: temp ! Temperature [ K] - real , intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] - real , intent(in), optional :: ricein ! Ice mixing ratio [ kg/kg] - !----- Local variables --------------------------------------------------------------! - real :: rice ! Ice mixing ratio or 0. [ kg/kg] - real :: ldrst ! L × d(rs)/dT × T [ J/kg] - real :: hh ! Sensible heat enthalpy [ J/kg] - real :: qq ! Latent heat enthalpy [ J/kg] - logical :: thereisice ! Is ice present [ ---] + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: humi ! Humidity (spec. hum. or mixing ratio) [ kg/kg] + logical , intent(in) :: is_shv ! Input humidity is specific humidity [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: shv ! Specific humidity [ kg/kg] !------------------------------------------------------------------------------------! - + + !------------------------------------------------------------------------------------! - ! Checking whether I should consider ice or not. ! + ! Copy specific humidity to shv. ! !------------------------------------------------------------------------------------! - thereisice = present(ricein) - - if (thereisice) then - rice=ricein - else - rice=0. - end if - - !----- No condensation, dthetail_dt is a constant -----------------------------------! - if (rliq+rice == 0.) then - dthetail_dt = thil/temp - return + if (is_shv) then + shv = humi else - hh = cp*temp !----- Sensible heat enthalpy - qq = alvl*rliq+alvi*rice !----- Latent heat enthalpy - !---------------------------------------------------------------------------------! - ! This is the term L×[d(rs)/dt]×T. L may be either the vapourisation or ! - ! sublimation latent heat, depending on the temperature and whether we are consi- ! - ! dering ice or not. Also, if condensation mixing ratio is constant, then this ! - ! term will be always zero. ! - !---------------------------------------------------------------------------------! - if (condconst) then - ldrst = 0. - elseif (thereisice .and. temp < t3ple) then - ldrst = alvi*rsifp(pres,temp)*temp - else - ldrst = alvl*rslfp(pres,temp)*temp - end if + shv = humi / (humi + 1.0) end if + !------------------------------------------------------------------------------------! - if (newthermo) then - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli) then - dthetail_dt = thil * (1. + (ldrst + qq)/hh) / temp - else - dthetail_dt = thil * (1. + ldrst*htripolii) / temp - end if - else - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli) then - dthetail_dt = thil * (1. + (ldrst + qq)/(hh+qq)) / temp - else - dthetail_dt = thil * (1. + ldrst/(htripoli + alvl*rliq)) / temp - end if - end if + + + !------------------------------------------------------------------------------------! + ! Enthalpy is the combination of dry and moist enthalpies, with the latter being ! + ! allowed to change phase. ! + !------------------------------------------------------------------------------------! + tq2enthalpy = (1.0 - shv) * cpdry * temp + shv * cph2o * (temp - tsupercool_vap) + !------------------------------------------------------------------------------------! return - end function dthetail_dt + end function tq2enthalpy !=======================================================================================! !=======================================================================================! @@ -1764,230 +2573,54 @@ end function dthetail_dt + !=======================================================================================! !=======================================================================================! - ! This function computes temperature from the ice-liquid water potential temperature ! - ! in Kelvin, Exner function in J/kg/K, and liquid and ice mixing ratios in kg/kg. ! - ! For now t1stguess is used only to decide whether I should use the complete case or ! - ! the 253 K to reduce the error on neglecting the changes on latent heat due to temper- ! - ! ature. ! + ! This function computes the temperature [K] given the specific enthalpy and ! + ! humidity. If we assume that latent heat of vaporisation is a linear function of ! + ! temperature (equivalent to assume that specific heats are constants and that the ! + ! thermal expansion of liquid and water are negligible), then the saturation disappears ! + ! and the enthalpy becomes a straightforward state function. In case you are looking ! + ! at water exchange only, set the specific humidity to 1.0 and multiply the result by ! + ! the water mass or water flux. ! !---------------------------------------------------------------------------------------! - real function thil2temp(thil,exner,pres,rliq,rice,t1stguess) - use rconstants, only: cp, cpi, alvl, alvi, t00, t3ple, ttripoli,htripolii,cpi4 + real(kind=4) function hq2temp(enthalpy,humi,is_shv) + use rconstants , only : cpdry & ! intent(in) + , cph2o & ! intent(in) + , tsupercool_vap ! ! intent(in) + implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: thil ! Ice-liquid water potential temperature [ K] - real, intent(in) :: exner ! Exner function [J/kg/K] - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] - real, intent(in) :: rice ! Ice mixing ratio [ kg/kg] - real, intent(in) :: t1stguess ! 1st. guess for temperature [ K] - !----- Local variables for iterative method -----------------------------------------! - real :: deriv ! Function derivative - real :: fun ! Function for which we seek a root. - real :: funa ! Smallest guess function - real :: funz ! Largest guess function - real :: tempa ! Smallest guess (or previous guess in Newton) - real :: tempz ! Largest guess (or new guess in Newton) - real :: delta ! Aux. var to compute 2nd guess for bisection - integer :: itn,itb ! Iteration counter - logical :: converged ! Convergence handle - logical :: zside ! Flag to check for one-sided approach... - real :: til ! Ice liquid temperature [ K] + real(kind=4), intent(in) :: enthalpy ! Specific enthalpy [ J/kg] + real(kind=4), intent(in) :: humi ! Humidity (spec. hum. or mixing ratio) [ kg/kg] + logical , intent(in) :: is_shv ! Input humidity is specific humidity [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: shv ! Specific humidity [ kg/kg] !------------------------------------------------------------------------------------! - !----- 1st. of all, check whether there is condensation. If not, theta_il = theta ---! - if (rliq+rice == 0.) then - thil2temp = cpi * thil * exner - return - !----- If not, check whether we are using the old thermo or the new one -------------! - elseif (.not. newthermo) then - til = cpi * thil * exner - if (t1stguess > ttripoli) then - thil2temp = 0.5 * (til + sqrt(til * (til + cpi4 * (alvl*rliq + alvi*rice)))) - else - thil2temp = til * ( 1. + (alvl*rliq+alvi*rice) * htripolii) - end if - return + !------------------------------------------------------------------------------------! + ! Copy specific humidity to shv. ! + !------------------------------------------------------------------------------------! + if (is_shv) then + shv = humi + else + shv = humi / (humi + 1.0) end if !------------------------------------------------------------------------------------! - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,a,1x,f11.4,2(1x,a,1x,es12.5))') & - ! 'itn=',itn,'bisection=',.false.,'tempz=',tempz-t00 & - ! ,'fun=',fun,'deriv=',deriv - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - - converged = abs(tempa-tempz) < toler*tempz - !----- Converged, happy with that, return the average b/w the 2 previous guesses -! - if (fun == 0.) then - thil2temp = tempz - converged = .true. - return - elseif(converged) then - thil2temp = 0.5 * (tempa+tempz) - return - end if - end do newloop - !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! Enthalpy is the combination of dry and moist enthalpies, with the latter being ! + ! allowed to change phase. ! + !------------------------------------------------------------------------------------! + hq2temp = ( enthalpy + shv * cph2o * tsupercool_vap ) & + / ( (1.0 - shv) * cpdry + shv * cph2o ) !------------------------------------------------------------------------------------! - if (funa * fun < 0.) then - funz = fun - zside = .true. - else - if (abs(fun-funa) < toler*tempa) then - delta = 100.*toler*tempa - else - delta = max(abs(funa * (tempz-tempa)/(fun-funa)),100.*toler*tempa) - end if - tempz = tempa + delta - zside = .false. - zgssloop: do itb=1,maxfpo - tempz = tempa + real((-1)**itb * (itb+3)/2) * delta - funz = theta_iceliq(exner,tempz,rliq,rice) - thil - zside = funa*funz < 0 - if (zside) exit zgssloop - end do zgssloop - if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'thil =',thil ,'t1st=',t1stguess - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'exner=',exner,'pres=',pres - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'rliq =',rliq ,'rice=',rice - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempa=',tempa,'funa=',funa - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempz=',tempz,'funz=',funz - write (unit=*,fmt='(1(a,1x,es14.7,1x))') 'delta=',delta - call abort_run('Failed finding the second guess for regula falsi' & - ,'thil2temp','therm_lib.f90') - end if - end if - - - bisloop: do itb=itn,maxfpo - thil2temp = (funz*tempa-funa*tempz)/(funz-funa) - - !---------------------------------------------------------------------------------! - ! Now that we updated the guess, check whether they are really close. If so, ! - ! it converged, I can use this as my guess. ! - !---------------------------------------------------------------------------------! - converged = abs(thil2temp-tempa)< toler*thil2temp - if (converged) exit bisloop - - !------ Finding the new function -------------------------------------------------! - fun = theta_iceliq(exner,tempz,rliq,rice) - thil - - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,6(1x,a,1x,f11.4))') & - ! 'itn=',itb,'bisection=',.true. & - ! ,'temp=',thil2temp-t00,'tempa=',tempa-t00,'tempz=',tempz-t00 & - ! ,'fun=',fun,'funa=',funa,'funz=',funz - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - - !------ Defining my new interval based on the intermediate value theorem. --------! - if (fun*funa < 0. ) then - tempz = thil2temp - funz = fun - !----- If we are updating zside again, modify aside (Illinois method) ---------! - if (zside) funa=funa * 0.5 - !----- We just updated zside, setting zside to true. --------------------------! - zside = .true. - else - tempa = thil2temp - funa = fun - !----- If we are updating aside again, modify aside (Illinois method) ---------! - if (.not. zside) funz=funz * 0.5 - !----- We just updated aside, setting aside to true. --------------------------! - zside = .false. - end if - end do bisloop - - - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> ttripoli) then - dtempdrs = - temp * qhydm / (rcon * (hh+qhydm)) - else - dtempdrs = - temp * qhydm * htripolii / rcon - end if - else - til = cpi * thil * exner - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli) then - dtempdrs = - til * qhydm /( rcon * cp * (2.*temp-til)) - else - dtempdrs = - til * qhydm * htripolii / rcon - end if - end if return - end function dtempdrs + end function alvl !=======================================================================================! !=======================================================================================! @@ -2061,35 +2661,27 @@ end function dtempdrs !=======================================================================================! !=======================================================================================! - ! This fucntion computes the change of ice-liquid potential temperature due to ! - ! sedimentation. The arguments are ice-liquid potential temperature, potential temper- ! - ! ature and temperature in Kelvin, the old and new mixing ratio [kg/kg] and the old and ! - ! new enthalpy [J/kg]. ! + ! This function finds the latent heat of sublimation for a given temperature. If ! + ! we use the definition of latent heat (difference in enthalpy between ice and vapour ! + ! phases), and assume that the specific heats are constants, latent heat becomes a ! + ! linear function of temperature. ! !---------------------------------------------------------------------------------------! - real function dthil_sedimentation(thil,theta,temp,rold,rnew,qrold,qrnew) - use rconstants, only: ttripoli,cp,alvi,alvl - + real(kind=4) function alvi(temp) + use rconstants , only : alvi3 & ! intent(in) + , dcpvi & ! intent(in) + , t3ple ! ! intent(in) implicit none - !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: thil ! Ice-liquid potential temperature [ K] - real, intent(in) :: theta ! Potential temperature [ K] - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: rold ! Old hydrometeor mixing ratio [ kg/kg] - real, intent(in) :: rnew ! New hydrometeor mixing ratio [ kg/kg] - real, intent(in) :: qrold ! Old hydrometeor latent enthalpy [ J/kg] - real, intent(in) :: qrnew ! New hydrometeor latent enthalpy [ J/kg] + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: temp !------------------------------------------------------------------------------------! - if (newthermo) then - dthil_sedimentation = - thil * (alvi*(rnew-rold) - (qrnew-qrold)) & - / (cp * max(temp,ttripoli)) - else - dthil_sedimentation = - thil*thil * (alvi*(rnew-rold) - (qrnew-qrold)) & - / (cp * max(temp,ttripoli) * theta) - end if + + !----- Linear function, using latent heat at the triple point as reference. ---------! + alvi = alvi3 + dcpvi * (temp - t3ple) + !------------------------------------------------------------------------------------! return - end function dthil_sedimentation + end function alvi !=======================================================================================! !=======================================================================================! @@ -2100,43 +2692,68 @@ end function dthil_sedimentation !=======================================================================================! !=======================================================================================! - ! This function computes the ice-vapour equivalent potential temperature from ! - ! theta_iland the total mixing ratio. This is equivalent to the equivalent potential ! - ! temperature considering also the effects of fusion/melting/sublimation. ! - ! In case you want to find thetae (i.e. without ice) simply provide the logical ! - ! useice as .false. . ! + ! This fucntion computes the ice liquid potential temperature given the Exner ! + ! function [J/kg/K], temperature [K], and liquid and ice mixing ratios [kg/kg]. ! !---------------------------------------------------------------------------------------! - real function thetaeiv(thil,pres,temp,rvap,rtot,iflg,useice) - use rconstants, only : alvl,alvi,cp,ep,p00,rocp,ttripoli,t3ple + real(kind=4) function theta_iceliq(exner,temp,rliq,rice) + use rconstants , only : alvl3 & ! intent(in) + , alvi3 & ! intent(in) + , cpdry & ! intent(in) + , ttripoli & ! intent(in) + , htripoli & ! intent(in) + , htripolii ! ! intent(in) + implicit none !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: thil ! Ice-liquid water potential temp. [ K] - real , intent(in) :: pres ! Pressure [ Pa] - real , intent(in) :: temp ! Temperature [ K] - real , intent(in) :: rvap ! Water vapour mixing ratio [ kg/kg] - real , intent(in) :: rtot ! Total mixing ratio [ kg/kg] - integer, intent(in) :: iflg ! Just to tell where this has been called. - logical, intent(in), optional :: useice ! Should I use ice? [ T|F] - !----- Local variables for iterative method -----------------------------------------! - real :: tlcl ! Internal LCL temperature [ K] - real :: plcl ! Lifting condensation pressure [ Pa] - real :: dzlcl ! Thickness of layer beneath LCL [ m] + real(kind=4), intent(in) :: exner ! Exner function [ J/kg/K] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] + real(kind=4), intent(in) :: rice ! Ice mixing ratio [ kg/kg] + !----- Local variables --------------------------------------------------------------! + real(kind=4) :: hh ! Enthalpy associated with sensible heat [ J/kg] + real(kind=4) :: qq ! Enthalpy associated with latent heat [ J/kg] !------------------------------------------------------------------------------------! - if (present(useice)) then - call lcl_il(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl,iflg,useice) + + !----- Find the sensible heat enthalpy (assuming dry air). --------------------------! + hh = cpdry * temp + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the latent heat enthalpy. If using the old thermodynamics, we use the ! + ! latent heat at T = T3ple, otherwise we use the temperature-dependent one. ! + !------------------------------------------------------------------------------------! + if (newthermo) then + qq = alvl(temp) * rliq + alvi(temp) * rice else - call lcl_il(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl,iflg) + qq = alvl3 * rliq + alvi3 * rice end if + !------------------------------------------------------------------------------------! + !------------------------------------------------------------------------------------! - ! The definition of the thetae_iv is the thetae_ivs at the LCL. The LCL, in turn ! - ! is the point in which rtot = rvap = rsat, so at the LCL rliq = rice = 0. ! + ! Solve the thermodynamics. For the new thermodynamics we don't approximate ! + ! the exponential to a linear function, nor do we impose temperature above the thre- ! + ! shold from Tripoli and Cotton (1981). ! + !------------------------------------------------------------------------------------! + if (newthermo) then + !----- Decide how to compute, based on temperature. ------------------------------! + theta_iceliq = hh * exp(-qq / hh) / exner + !---------------------------------------------------------------------------------! + else + !----- Decide how to compute, based on temperature. ------------------------------! + if (temp > ttripoli) then + theta_iceliq = hh * hh / (exner * ( hh + qq)) + else + theta_iceliq = hh * htripoli / (exner * ( htripoli + qq)) + end if + !---------------------------------------------------------------------------------! + end if !------------------------------------------------------------------------------------! - thetaeiv = thetaeivs(thil,tlcl,rtot,0.,0.) return - end function thetaeiv + end function theta_iceliq !=======================================================================================! !=======================================================================================! @@ -2147,49 +2764,132 @@ end function thetaeiv !=======================================================================================! !=======================================================================================! - ! This function computes the derivative of ice-vapour equivalent potential tempera- ! - ! ture, based on the expression used to compute the ice-vapour equivalent potential ! - ! temperature (function thetaeiv). ! - ! ! - ! IMPORTANT!!! This CANNOT BE USED to compute d(Thetae_ivs)/dT, because here ! - ! we assume that T(LCL) and saturation mixing ratio are known and ! - ! constants, and that the LCL pressure (actually the saturation vapour ! - ! pressure at the LCL) is a function of temperature. In case you want ! - ! d(Thetae_ivs)/dT, use the dthetaeivs_dt function instead. ! + ! This function computes the liquid potential temperature derivative with respect ! + ! to temperature, useful in iterative methods. ! !---------------------------------------------------------------------------------------! - real function dthetaeiv_dtlcl(theiv,tlcl,rtot,eslcl,useice) - use rconstants, only : rocp,aklv,ttripoli + real(kind=4) function dthetail_dt(condconst,thil,exner,pres,temp,rliq,ricein) + use rconstants , only : alvl3 & ! intent(in) + , alvi3 & ! intent(in) + , dcpvi & ! intent(in) + , dcpvl & ! intent(in) + , cpdry & ! intent(in) + , ttripoli & ! intent(in) + , htripoli & ! intent(in) + , htripolii & ! intent(in) + , t3ple ! ! intent(in) + implicit none !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: theiv ! Ice-vapour equiv. pot. temp. [ K] - real , intent(in) :: tlcl ! LCL temperature [ K] - real , intent(in) :: rtot ! Total mixing ratio (rs @ LCL) [ Pa] - real , intent(in) :: eslcl ! LCL saturation vapour pressure [ Pa] - logical, intent(in), optional :: useice ! Flag for considering ice [ T|F] + logical , intent(in) :: condconst ! Condensation is constant? [ T|F] + real(kind=4), intent(in) :: thil ! Ice liquid pot. temp. [ K] + real(kind=4), intent(in) :: exner ! Exner function [J/kg/K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] + real(kind=4), intent(in), optional :: ricein ! Ice mixing ratio [ kg/kg] !----- Local variables --------------------------------------------------------------! - real :: desdtlcl ! Saturated vapour pres. deriv. [ Pa/K] + real(kind=4) :: rice ! Ice mixing ratio or 0. [ kg/kg] + real(kind=4) :: ldrst ! L × d(rs)/dT × T [ J/kg] + real(kind=4) :: rdlt ! r × d(L)/dT × T [ J/kg] + real(kind=4) :: hh ! Sensible heat enthalpy [ J/kg] + real(kind=4) :: qq ! Latent heat enthalpy [ J/kg] + logical :: thereisice ! Is ice present [ ---] !------------------------------------------------------------------------------------! + !------------------------------------------------------------------------------------! + ! Check whether we should consider ice thermodynamics or not. ! + !------------------------------------------------------------------------------------! + thereisice = present(ricein) + if (thereisice) then + rice = ricein + else + rice = 0. + end if + !------------------------------------------------------------------------------------! + - !----- Finding the derivative of rs with temperature --------------------------------! - if (present(useice)) then - desdtlcl = eslifp(tlcl,useice) + !------------------------------------------------------------------------------------! + ! Check whether the current state has condensed water. ! + !------------------------------------------------------------------------------------! + if (rliq+rice == 0.) then + !----- No condensation, so dthetail_dt is a constant. ----------------------------! + dthetail_dt = thil/temp + return + !---------------------------------------------------------------------------------! else - desdtlcl = eslifp(tlcl) + !---------------------------------------------------------------------------------! + ! Condensation exists. Compute some auxiliary variables. ! + !---------------------------------------------------------------------------------! + + + !---- Sensible heat enthalpy. ----------------------------------------------------! + hh = cpdry * temp + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! Find the latent heat enthalpy. If using the old thermodynamics, we use ! + ! the latent heat at T = T3ple, otherwise we use the temperature-dependent one. ! + ! The term r × d(L)/dT × T is computed only when we use the new thermodynamics. ! + !---------------------------------------------------------------------------------! + if (newthermo) then + qq = alvl(temp) * rliq + alvi(temp) * rice + rdlt = (dcpvl * rliq + dcpvi * rice ) * temp + else + qq = alvl3 * rliq + alvi3 * rice + rdlt = 0.0 + end if + !---------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------! + ! This is the term L×[d(rs)/dt]×T. L may be either the vapourisation or ! + ! sublimation latent heat, depending on the temperature and whether we are consi- ! + ! dering ice or not. We still need to check whether latent heat is a function of ! + ! temperature or not. Also, if condensation mixing ratio is constant, then this ! + ! term will be always zero. ! + !---------------------------------------------------------------------------------! + if (condconst) then + ldrst = 0. + elseif (thereisice .and. temp < t3ple) then + if (newthermo) then + ldrst = alvi3 * rsifp(pres,temp) * temp + else + ldrst = alvi(temp) * rsifp(pres,temp) * temp + end if + else + if (newthermo) then + ldrst = alvl3 * rslfp(pres,temp) * temp + else + ldrst = alvl(temp) * rslfp(pres,temp) * temp + end if + end if + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! - !----- Finding the derivative. Depending on the temperature, use different eqn. -----! - if (tlcl > ttripoli) then - dthetaeiv_dtlcl = theiv * (1. - rocp*tlcl*desdtlcl/eslcl - aklv*rtot/tlcl) / tlcl + !------------------------------------------------------------------------------------! + ! Find the condensed phase consistent with the thermodynamics used. ! + !------------------------------------------------------------------------------------! + if (newthermo) then + dthetail_dt = thil * ( 1. + (ldrst + qq - rdlt ) / hh ) / temp else - dthetaeiv_dtlcl = theiv * (1. - rocp*tlcl*desdtlcl/eslcl ) / tlcl + !----- Decide how to compute, based on temperature. ------------------------------! + if (temp > ttripoli) then + dthetail_dt = thil * ( 1. + (ldrst + qq) / (hh+qq) ) / temp + else + dthetail_dt = thil * ( 1. + ldrst / (htripoli + alvl3 * rliq) ) / temp + end if + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return - end function dthetaeiv_dtlcl + end function dthetail_dt !=======================================================================================! !=======================================================================================! @@ -2200,38 +2900,257 @@ end function dthetaeiv_dtlcl !=======================================================================================! !=======================================================================================! - ! This function computes the saturation ice-vapour equivalent potential temperature ! - ! from theta_il and the total mixing ratio (split into saturated vapour plus liquid and ! - ! ice. This is equivalent to the equivalent potential temperature considering also the ! - ! effects of fusion/melting/sublimation, and it is done separatedly from the regular ! - ! thetae_iv because it doesn't require iterations. ! - ! ! - ! References: ! - ! Tripoli, J. T.; and Cotton, W.R., 1981: The use of ice-liquid water potential tem- ! - ! perature as a thermodynamic variable in deep atmospheric models. Mon. Wea. ! - ! Rev., v. 109, 1094-1102. (TC81) ! - ! ! - ! Some algebra was needed to find this equation, essentially combining (TC81-26) and ! - ! (TC81-27), and the conservation of total water (TC81-16). It assumes that the divi- ! - ! sion between the three phases is already taken care of. ! + ! This function computes temperature from the ice-liquid water potential temperature ! + ! in Kelvin, Exner function in J/kg/K, and liquid and ice mixing ratios in kg/kg. ! + ! For now t1stguess is used only to decide whether I should use the complete case or ! + ! the 253 K to reduce the error on neglecting the changes on latent heat due to temper- ! + ! ature. ! !---------------------------------------------------------------------------------------! - real function thetaeivs(thil,temp,rsat,rliq,rice) - use rconstants, only : aklv, ttripoli + real(kind=4) function thil2temp(thil,exner,pres,rliq,rice,t1stguess) + use rconstants , only : cpdry & ! intent(in) + , cpdryi & ! intent(in) + , cpdryi4 & ! intent(in) + , alvl3 & ! intent(in) + , alvi3 & ! intent(in) + , t00 & ! intent(in) + , t3ple & ! intent(in) + , ttripoli & ! intent(in) + , htripolii ! ! intent(in) implicit none - real, intent(in) :: thil ! Theta_il, ice-liquid water potential temp. [ K] - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: rsat ! Saturation water vapour mixing ratio [ kg/kg] - real, intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] - real, intent(in) :: rice ! Ice mixing ratio [ kg/kg] + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: thil ! Ice-liquid water potential temp. [ K] + real(kind=4), intent(in) :: exner ! Exner function [J/kg/K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] + real(kind=4), intent(in) :: rice ! Ice mixing ratio [ kg/kg] + real(kind=4), intent(in) :: t1stguess ! 1st. guess for temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: til ! Ice liquid temperature [ K] + real(kind=4) :: deriv ! Function derivative + real(kind=4) :: fun ! Function for which we seek a root. + real(kind=4) :: funa ! Smallest guess function + real(kind=4) :: funz ! Largest guess function + real(kind=4) :: tempa ! Smallest guess (or previous guess in Newton) + real(kind=4) :: tempz ! Largest guess (or new guess in Newton) + real(kind=4) :: delta ! Aux. var to compute 2nd guess for bisection + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + logical :: converged ! Convergence flag + logical :: zside ! Flag to check for one-sided approach... + !------------------------------------------------------------------------------------! - real :: rtots ! Saturated mixing ratio [ K] - rtots = rsat+rliq+rice - - thetaeivs = thil * exp ( aklv * rtots / max(temp,ttripoli)) + !------------------------------------------------------------------------------------! + ! First we check for conditions that don't require iterative root-finding. ! + !------------------------------------------------------------------------------------! + if (rliq + rice == 0.) then + !----- No condensation. Theta_il is the same as theta. --------------------------! + thil2temp = cpdryi * thil * exner + return + !---------------------------------------------------------------------------------! + elseif (.not. newthermo) then + !---------------------------------------------------------------------------------! + ! There is condensation but we are using the old thermodynamics, which can be ! + ! solved analytically. ! + !---------------------------------------------------------------------------------! + til = cpdryi * thil * exner + if (t1stguess > ttripoli) then + thil2temp = 0.5 & + * (til + sqrt(til * (til + cpdryi4 * (alvl3 * rliq + alvi3 * rice)))) + else + thil2temp = til * ( 1. + (alvl3 * rliq + alvi3 * rice) * htripolii) + end if + return + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,a,1x,f11.4,2(1x,a,1x,es12.5))') & + ! 'itn=',itn,'bisection=',.false.,'tempz=',tempz-t00 & + ! ,'fun=',fun,'deriv=',deriv + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + converged = abs(tempa-tempz) < toler*tempz + !----- Converged, happy with that, return the average b/w the 2 previous guesses -! + if (fun == 0.) then + thil2temp = tempz + converged = .true. + return + elseif(converged) then + thil2temp = 0.5 * (tempa+tempz) + return + end if + end do newloop + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! If we have reached this point then Newton's method failed. Use bisection ! + ! instead. For bisection, We need two guesses whose function evaluations have ! + ! opposite sign. ! + !------------------------------------------------------------------------------------! + if (funa * fun < 0.) then + !----- Guesses have opposite sign. -----------------------------------------------! + funz = fun + zside = .true. + else + if (abs(fun-funa) < toler*tempa) then + delta = 100.*toler*tempa + else + delta = max(abs(funa * (tempz-tempa)/(fun-funa)),100.*toler*tempa) + end if + tempz = tempa + delta + zside = .false. + zgssloop: do itb=1,maxfpo + tempz = tempa + real((-1)**itb * (itb+3)/2) * delta + funz = theta_iceliq(exner,tempz,rliq,rice) - thil + zside = funa*funz < 0.0 + if (zside) exit zgssloop + end do zgssloop + if (.not. zside) then + write (unit=*,fmt='(a)') ' No second guess for you...' + write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'thil =',thil ,'t1st=',t1stguess + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'exner=',exner,'pres=',pres + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'rliq =',rliq ,'rice=',rice + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempa=',tempa,'funa=',funa + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempz=',tempz,'funz=',funz + write (unit=*,fmt='(1(a,1x,es14.7,1x))') 'delta=',delta + call abort_run ('Failed finding the second guess for regula falsi' & + ,'thil2temp','therm_lib.f90') + end if + end if + + + bisloop: do itb=itn,maxfpo + thil2temp = (funz*tempa-funa*tempz)/(funz-funa) + + !---------------------------------------------------------------------------------! + ! Now that we updated the guess, check whether they are really close. If so, ! + ! it converged, I can use this as my guess. ! + !---------------------------------------------------------------------------------! + converged = abs(thil2temp-tempa)< toler*thil2temp + if (converged) exit bisloop + + !------ Finding the new function -------------------------------------------------! + fun = theta_iceliq(exner,tempz,rliq,rice) - thil + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,6(1x,a,1x,f11.4))') & + ! 'itn=',itb,'bisection=',.true. & + ! ,'temp=',thil2temp-t00,'tempa=',tempa-t00,'tempz=',tempz-t00 & + ! ,'fun=',fun,'funa=',funa,'funz=',funz + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + !------ Defining my new interval based on the intermediate value theorem. --------! + if (fun*funa < 0. ) then + tempz = thil2temp + funz = fun + !----- If we are updating zside again, modify aside (Illinois method) ---------! + if (zside) funa=funa * 0.5 + !----- We just updated zside, setting zside to true. --------------------------! + zside = .true. + else + tempa = thil2temp + funa = fun + !----- If we are updating aside again, modify aside (Illinois method) ---------! + if (.not. zside) funz=funz * 0.5 + !----- We just updated aside, setting aside to true. --------------------------! + zside = .false. + end if + end do bisloop + + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> ttripoli) then + dtempdrs = - til * qq / ( rcon * cpdry * (2.*temp-til)) + else + dtempdrs = - til * qq * htripolii / rcon + end if + !------------------------------------------------------------------------------! + end if + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + return + end function dtempdrs + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the ice-vapour equivalent potential temperature from ! + ! theta_iland the total mixing ratio. This is equivalent to the equivalent potential ! + ! temperature considering also the effects of fusion/melting/sublimation. ! + ! In case you want to find thetae (i.e. without ice) simply set the the logical ! + ! useice to .false. . ! + !---------------------------------------------------------------------------------------! + real(kind=4) function thetaeiv(thil,pres,temp,rvap,rtot,useice) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: thil ! Ice-liquid potential temp. [ K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rvap ! Water vapour mixing ratio [ kg/kg] + real(kind=4), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! Should I use ice? [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: tlcl ! Internal LCL temperature [ K] + real(kind=4) :: plcl ! Lifting condensation pressure [ Pa] + real(kind=4) :: dzlcl ! Thickness of lyr. beneath LCL [ m] + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Find the liquid condensation level (LCL). ! + !------------------------------------------------------------------------------------! + if (present(useice)) then + call lcl_il(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl,useice) + else + call lcl_il(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl) + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! The definition of the thetae_iv is the thetae_ivs at the LCL. The LCL, in turn ! + ! is the point in which rtot = rvap = rsat, so at the LCL rliq = rice = 0. ! + !------------------------------------------------------------------------------------! + thetaeiv = thetaeivs(thil,tlcl,rtot,0.,0.) + !------------------------------------------------------------------------------------! + + return + end function thetaeiv + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the derivative of ice-vapour equivalent potential tempera- ! + ! ture, based on the expression used to compute the ice-vapour equivalent potential ! + ! temperature (function thetaeiv). ! + ! ! + ! IMPORTANT!!! This CANNOT BE USED to compute d(Thetae_ivs)/dT, because here ! + ! we assume that T(LCL) and saturation mixing ratio are known and ! + ! constants, and that the LCL pressure (actually the saturation vapour ! + ! pressure at the LCL) is a function of temperature. In case you want ! + ! d(Thetae_ivs)/dT, use the dthetaeivs_dt function instead. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function dthetaeiv_dtlcl(theiv,tlcl,rtot,eslcl,useice) + use rconstants , only : rocp & ! intent(in) + , cpdry & ! intent(in) + , dcpvl ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: theiv ! Ice-vap. equiv. pot. temp. [ K] + real(kind=4), intent(in) :: tlcl ! LCL temperature [ K] + real(kind=4), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + real(kind=4), intent(in) :: eslcl ! LCL sat. vapour pressure [ Pa] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! Flag for considering ice [ T|F] + !----- Local variables --------------------------------------------------------------! + real(kind=4) :: desdtlcl ! Sat. vapour pres. deriv. [ Pa/K] + real(kind=4) :: esterm ! es(TLC) term [ ----] + real(kind=4) :: hhlcl ! Enthalpy -- sensible [ J/kg] + real(kind=4) :: qqlcl ! Enthalpy -- latent [ J/kg] + real(kind=4) :: qptlcl ! Latent deriv. * T_LCL [ J/kg] + !------------------------------------------------------------------------------------! + + + + !----- Find the derivative of rs with temperature. ----------------------------------! + if (present(useice)) then + desdtlcl = eslifp(tlcl,useice) + else + desdtlcl = eslifp(tlcl) + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Saturation term. ! + !------------------------------------------------------------------------------------! + esterm = rocp * tlcl * desdtlcl / eslcl + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the enthalpy terms. ! + !------------------------------------------------------------------------------------! + hhlcl = cpdry * tlcl + qqlcl = alvl(tlcl) * rtot + qptlcl = dcpvl * rtot * tlcl + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Derivative. ! + !------------------------------------------------------------------------------------! + dthetaeiv_dtlcl = theiv / tlcl * (1. - esterm - (qqlcl - qptlcl) / hhlcl) + !------------------------------------------------------------------------------------! + + return + end function dthetaeiv_dtlcl + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the saturation ice-vapour equivalent potential temperature ! + ! from theta_il and the total mixing ratio (split into saturated vapour plus liquid and ! + ! ice. This is equivalent to the equivalent potential temperature considering also the ! + ! effects of fusion/melting/sublimation, and it is done separatedly from the regular ! + ! thetae_iv because it doesn't require iterations. ! + ! ! + ! References: ! + ! Tripoli, J. T.; and Cotton, W.R., 1981: The use of ice-liquid water potential tem- ! + ! perature as a thermodynamic variable in deep atmospheric models. Mon. Wea. ! + ! Rev., v. 109, 1094-1102. (TC81) ! + ! ! + ! Some algebra was needed to find this equation, essentially combining (TC81-26) and ! + ! (TC81-27), and the conservation of total water (TC81-16). It assumes that the divi- ! + ! sion between the three phases is already taken care of. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function thetaeivs(thil,temp,rsat,rliq,rice) + use rconstants , only : cpdry ! ! intent(in) + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: thil ! Theta_il, ice-liquid water pot. temp. [ K] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rsat ! Saturation water vapour mixing ratio [ kg/kg] + real(kind=4), intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] + real(kind=4), intent(in) :: rice ! Ice mixing ratio [ kg/kg] + !----- Local variables --------------------------------------------------------------! + real(kind=4) :: rtots ! Saturated mixing ratio [ K] + !------------------------------------------------------------------------------------! + + + !------ Find the total saturation mixing ratio. -------------------------------------! + rtots = rsat+rliq+rice + !------------------------------------------------------------------------------------! + + + !------ Find the saturation equivalent potential temperature. -----------------------! + thetaeivs = thil * exp ( alvl(temp) * rtots / (cpdry * temp)) + !------------------------------------------------------------------------------------! + + return + end function thetaeivs + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the derivative of saturation ice-vapour equivalent ! + ! potential temperature, based on the expression used to compute the saturation ! + ! ice-vapour equivalent potential temperature (function thetaeivs). ! + ! ! + ! IMPORTANT!!! This CANNOT BE USED to compute d(Thetae_iv)/d(T_LCL), because here ! + ! we assume that temperature and pressure are known and constants, and ! + ! that the mixing ratio is a function of temperature. In case you want ! + ! d(Thetae_iv)/d(T_LCL), use the dthetaeiv_dtlcl function instead. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function dthetaeivs_dt(theivs,temp,pres,rsat,useice) + use rconstants , only : cpdry & ! intent(in) + , dcpvl ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: theivs ! Sat. ice-vap. eq. pot. temp. [ K] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! Flag for considering ice [ T|F] + !----- Local variables --------------------------------------------------------------! + real(kind=4) :: drsdt ! Sat. mixing ratio derivative [kg/kg/K] + real(kind=4) :: hh ! Enthalpy -- sensible [ J/kg] + real(kind=4) :: qqaux ! Enthalpy -- sensible [ J/kg] + !------------------------------------------------------------------------------------! + + + !----- Find the derivative of rs with temperature and associated term. --------------! + if (present(useice)) then + drsdt = rslifp(pres,temp,useice) + else + drsdt = rslifp(pres,temp) + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Find the enthalpy terms. ! + !------------------------------------------------------------------------------------! + hh = cpdry * temp + qqaux = alvl(temp) * (drsdt * temp - rsat) + dcpvl * rsat * temp + !------------------------------------------------------------------------------------! + + + !----- Find the derivative. Depending on the temperature, use different eqn. -------! + dthetaeivs_dt = theivs / temp * ( 1. + qqaux / hh ) + !------------------------------------------------------------------------------------! + + return + end function dthetaeivs_dt + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function finds the ice-liquid potential temperature from the ice-vapour equi- ! + ! valent potential temperature. ! + ! Important remarks: ! + ! 1. If you don't want to use ice thermodynamics, simply force useice to be .false. ! + ! Otherwise, the model will decide based on the LEVEL given by the user from their ! + ! RAMSIN. ! + ! 2. If rtot < rsat, then this will convert theta_e into theta, which can be thought as ! + ! a particular case. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function thetaeiv2thil(theiv,pres,rtot,useice) + use rconstants , only : ep & ! intent(in) + , cpdry & ! intent(in) + , p00 & ! intent(in) + , rocp & ! intent(in) + , t3ple & ! intent(in) + , t00 ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: theiv ! Ice vap. equiv. pot. temp. [ K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May I use ice thermodyn. [ T|F] + !----- Local variables for iterative method -----------------------------------------! + real(kind=4) :: pvap ! Sat. vapour pressure + real(kind=4) :: theta ! Potential temperature + real(kind=4) :: deriv ! Function derivative + real(kind=4) :: funnow ! Function for which we seek a root. + real(kind=4) :: funa ! Smallest guess function + real(kind=4) :: funz ! Largest guess function + real(kind=4) :: tlcla ! Smallest guess (Newton: old guess) + real(kind=4) :: tlclz ! Largest guess (Newton: new guess) + real(kind=4) :: tlcl ! What will be the LCL temperature + real(kind=4) :: es00 ! Defined as p00*rt/(epsilon + rt) + real(kind=4) :: delta ! Aux. variable (For 2nd guess). + integer :: itn ! Iteration counters + integer :: itb ! Iteration counters + integer :: ii ! Another counter + logical :: converged ! Convergence handle + logical :: zside ! Side checker for Regula Falsi + logical :: frozen ! Will use ice thermodynamics + !------------------------------------------------------------------------------------! + + + + !----- Fill the flag for ice thermodynamics so it will be present. ------------------! + if (present(useice)) then + frozen = useice + else + frozen = bulk_on + end if + !------------------------------------------------------------------------------------! + + + + !----- Find es00, which is a constant. ----------------------------------------------! + es00 = p00 * rtot / (ep+rtot) + !------------------------------------------------------------------------------------! + + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + ! 'NEWTON: it=',itn,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funnow & + ! ,'deriv=',deriv + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + converged = abs(tlcla-tlclz) < toler * tlclz + if (funnow == 0.) then + tlcl = tlclz + funz = funnow + converged = .true. + exit newloop + elseif (converged) then + tlcl = 0.5*(tlcla+tlclz) + funz = funnow + exit newloop + end if + end do newloop + + !------------------------------------------------------------------------------------! + ! If I reached this point then it's because Newton's method failed. Using bisec- ! + ! tion instead. ! + !------------------------------------------------------------------------------------! + if (.not. converged) then + !----- Set funz, and check whether funa and funz already have opposite sign. -----! + funz = funnow + zside=.true. + if (funa*funnow > 0.) then + !----- We fix funa, and try a funz that will work as 2nd guess ----------------! + if (abs(funz-funa) < toler*tlcla) then + delta = 100.*toler*tlcla + else + delta = max(abs(funa*(tlclz-tlcla)/(funz-funa)),100.*toler*tlcla) + end if + tlclz = tlcla + delta + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + ! '2NGGSS: tt=',itb,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funz & + ! ,'delta=',delta + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + zside = funa*funz < 0. + if (zside) exit zgssloop + end do zgssloop + if (.not. zside) then + write (unit=*,fmt='(a)') ' No second guess for you...' + write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theiv =',theiv ,'rtot =',rtot + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'pres =',pres ,'pvap =',pvap + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theta =',theta ,'delta =',delta + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlcla =',tlcla ,'funa =',funa + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlclz =',tlclz ,'funz =',funz + call abort_run ('Failed finding the second guess for regula falsi' & + ,'thetaeiv2thil','therm_lib.f90') + end if + end if + !---- Continue iterative method. -------------------------------------------------! + fpoloop: do itb=itn+1,maxfpo + + !----- Update the guess. ------------------------------------------------------! + tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) + + !----- Updating function evaluation -------------------------------------------! + pvap = eslif(tlcl,frozen) + theta = tlcl * (es00/pvap)**rocp + funnow = thetaeivs(theta,tlcl,rtot,0.,0.) - theiv + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=36,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + ! 'ANSWER: itb=',itn,'tlcl=',tlcl-t00,'eslcl=',0.01*pvap & + ! ,'thil=',thetaeiv2thil,'funa=',funa,'funz=',funz + !write (unit=36,fmt='(a)') '-------------------------------------------------------' + !write (unit=36,fmt='(a)') ' ' + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + else + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + write (unit=*,fmt='(a)') ' THEIV2THIL failed!' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Input: ' + write (unit=*,fmt='(a,1x,f12.5)') ' THEIV [ K]:',theiv + write (unit=*,fmt='(a,1x,f12.5)') ' PRES [ Pa]:',pres * 100. + write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1000.*rtot + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Output: ' + write (unit=*,fmt='(a,1x,i12)') ' ITERATIONS :',itb + write (unit=*,fmt='(a,1x,f12.5)') ' PVAP [ hPa]:',pvap + write (unit=*,fmt='(a,1x,f12.5)') ' THETA [ K]:',theta + write (unit=*,fmt='(a,1x,f12.5)') ' TLCL [ °C]:',tlcl-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' TLCLA [ °C]:',tlcla-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' TLCLZ [ °C]:',tlclz-t00 + write (unit=*,fmt='(a,1x,es12.5)') ' FUNA [ K]:',funa + write (unit=*,fmt='(a,1x,es12.5)') ' FUNZ [ K]:',funz + write (unit=*,fmt='(a,1x,es12.5)') ' DERIV [ ---]:',deriv + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_A [ ---]:',abs(tlcl-tlcla)/tlcl + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_Z [ ---]:',abs(tlcl-tlclz)/tlcl + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + + call abort_run ('TLCL didn''t converge, qgave up!' & + ,'thetaeiv2thil','therm_lib.f90') + end if + + return + end function thetaeiv2thil + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This subroutine converts saturated ice-vapour equivalent potential temperature ! + ! into temperature, given pressure in Pa, and theta_es in Kelvin. It also returns the ! + ! potential temperature in Kelvin, and saturation vapour mixing ratio in kg/kg. As ! + ! usual, we seek T using Newton's method as a starting point, and if it fails, we fall ! + ! back to the modified regula falsi (Illinois method). ! + ! ! + ! OBS: In case you want to ignore ice, send useice as false. The default is to consider ! + ! when level >= 3 and to ignore otherwise. ! + !---------------------------------------------------------------------------------------! + subroutine thetaeivs2temp(theivs,pres,theta,temp,rsat,useice) + use rconstants , only : cpdry & ! intent(in) + , ep & ! intent(in) + , p00 & ! intent(in) + , rocp & ! intent(in) + , t00 ! ! intent(in) + implicit none + !----- Arguments --------------------------------------------------------------------! + real(kind=4), intent(in) :: theivs ! Sat. thetae_iv [ K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(out) :: theta ! Potential temperature [ K] + real(kind=4), intent(out) :: temp ! Temperature [ K] + real(kind=4), intent(out) :: rsat ! Saturation mixing ratio [ kg/kg] + logical , intent(in) , optional :: useice ! May use ice thermodyn. [ T|F] + !----- Local variables, with other thermodynamic properties -------------------------! + real(kind=4) :: exnernormi ! 1./ (Norm. Exner func.) [ ---] + logical :: frozen ! Will use ice thermodyn. [ T|F] + !----- Local variables for iterative method -----------------------------------------! + real(kind=4) :: deriv ! Function derivative + real(kind=4) :: funnow ! Current function evaluation + real(kind=4) :: funa ! Smallest guess function + real(kind=4) :: funz ! Largest guess function + real(kind=4) :: tempa ! Smallest guess (Newton: previous) + real(kind=4) :: tempz ! Largest guess (Newton: new) + real(kind=4) :: delta ! Aux. variable for 2nd guess. + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + logical :: converged ! Convergence handle + logical :: zside ! Flag for side check. + !------------------------------------------------------------------------------------! + + + !----- Set up the ice check, in case useice is not present. -------------------------! + if (present(useice)) then + frozen = useice + else + frozen = bulk_on + end if + !------------------------------------------------------------------------------------! + + + + !----- Finding the inverse of normalised Exner, which is constant in this routine ---! + exnernormi = (p00 /pres) ** rocp + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! The 1st. guess, no idea, guess 0°C. ! + !------------------------------------------------------------------------------------! + tempz = t00 + theta = tempz * exnernormi + rsat = rslif(pres,tempz,frozen) + funnow = thetaeivs(theta,tempz,rsat,0.,0.) + deriv = dthetaeivs_dt(funnow,tempz,pres,rsat,frozen) + funnow = funnow - theivs + !------------------------------------------------------------------------------------! + + + !----- Copy here just in case Newton is aborted at the 1st guess. -------------------! + tempa = tempz + funa = funnow + !------------------------------------------------------------------------------------! + + converged = .false. + !----- Newton's method loop. --------------------------------------------------------! + newloop: do itn=1,maxfpo/6 + if (abs(deriv) < toler) exit newloop !----- Too dangerous, skip to bisection -----! + !----- Updating guesses ----------------------------------------------------------! + tempa = tempz + funa = funnow + + tempz = tempa - funnow/deriv + theta = tempz * exnernormi + rsat = rslif(pres,tempz,frozen) + funnow = thetaeivs(theta,tempz,rsat,0.,0.) + deriv = dthetaeivs_dt(funnow,tempz,pres,rsat,frozen) + funnow = funnow - theivs + + converged = abs(tempa-tempz) < toler*tempz + if (funnow == 0.) then + converged =.true. + temp = tempz + exit newloop + elseif (converged) then + temp = 0.5*(tempa+tempz) + exit newloop + end if + end do newloop + !------------------------------------------------------------------------------------! + ! If we have reached this point then it's because Newton's method failed. Use ! + ! bisection instead. ! + !------------------------------------------------------------------------------------! + if (.not. converged) then + !----- Set funz, and check whether funa and funz already have opposite sign. -----! + funz = funnow + zside = .false. + !---------------------------------------------------------------------------------! + if (funa*funnow > 0.) then + !----- We fix funa, and try a funz that will work as 2nd guess ----------------! + if (abs(funz-funa) < toler*tempa) then + delta = 100.*toler*tempa + else + delta = max(abs(funa*(tempz-tempa)/(funz-funa)),100.*toler*tempa) + end if + !------------------------------------------------------------------------------! - !----- Finding the derivative of rs with temperature --------------------------------! - if (present(useice)) then - drsdt = rslifp(pres,temp,useice) - else - drsdt = rslifp(pres,temp) - end if + tempz = tempa + delta + zgssloop: do itb=1,maxfpo + !----- So this will be +1 -1 +2 -2 etc. ------------------------------------! + tempz = tempz + real((-1)**itb * (itb+3)/2) * delta + theta = tempz * exnernormi + rsat = rslif(pres,tempz,frozen) + funz = thetaeivs(theta,tempz,rsat,0.,0.) - theivs + zside = funa*funz < 0. + if (zside) exit zgssloop + end do zgssloop + if (.not. zside) then + call abort_run ('Failed finding the second guess for regula falsi' & + ,'thetaes2temp','therm_lib.f90') + end if + end if + !---- Continue iterative method --------------------------------------------------! + fpoloop: do itb=itn+1,maxfpo + if (abs(funz-funa) < toler*tempa) then + temp = 0.5*(tempa+tempz) + else + temp = (funz*tempa-funa*tempz)/(funz-funa) + end if + theta = temp * exnernormi + rsat = rslif(pres,temp,frozen) + funnow = thetaeivs(theta,temp,rsat,0.,0.) - theivs + !------------------------------------------------------------------------------! + ! Checking for convergence. If it did, return, we found the solution. ! + ! Otherwise, constrain the guesses. ! + !------------------------------------------------------------------------------! + converged = abs(temp-tempa) < toler*temp + if (converged) then + exit fpoloop + elseif (funnow*funa < 0.) then + tempz = temp + funz = funnow + !----- If we are updating zside again, modify aside (Illinois method) ------! + if (zside) funa=funa * 0.5 + !----- We just updated zside, setting zside to true. -----------------------! + zside = .true. + else + tempa = temp + funa = funnow + !----- If we are updating aside again, modify zside (Illinois method) ------! + if (.not. zside) funz = funz * 0.5 + !----- We just updated aside, setting zside to false -----------------------! + zside = .false. + end if + end do fpoloop + end if - !----- Finding the derivative. Depending on the temperature, use different eqn. -----! - if (temp > ttripoli) then - dthetaeivs_dt = theivs * (1. + aklv * (drsdt*temp-rsat)/temp ) / temp + if (converged) then + !----- Compute theta and rsat with temp just for consistency ---------------------! + theta = temp * exnernormi + rsat = rslif(pres,temp,frozen) else - dthetaeivs_dt = theivs * (1. + alvl * drsdt * temp * htripolii ) / temp + call abort_run ('Temperature didn''t converge, I gave up!' & + ,'thetaes2temp','therm_lib.f90') end if - return - end function dthetaeivs_dt + end subroutine thetaeivs2temp !=======================================================================================! !=======================================================================================! @@ -2293,258 +3973,348 @@ end function dthetaeivs_dt !=======================================================================================! !=======================================================================================! - ! This function finds the ice-liquid potential temperature from the ice-vapour equi- ! - ! valent potential temperature. ! + ! This subroutine finds the lifting condensation level given the ice-liquid ! + ! potential temperature in Kelvin, temperature in Kelvin, the pressure in Pascal, and ! + ! the mixing ratio in kg/kg. The output will give the LCL temperature and pressure, and ! + ! the thickness of the layer between the initial point and the LCL. ! + ! ! + ! References: ! + ! Tripoli, J. T.; and Cotton, W.R., 1981: The use of ice-liquid water potential ! + ! temperature as a thermodynamic variable in deep atmospheric models. Mon. Wea. ! + ! Rev., v. 109, 1094-1102. (TC81) ! + ! Bolton, D., 1980: The computation of the equivalent potential temperature. Mon. ! + ! Wea. Rev., v. 108, 1046-1053. (BO80) ! + ! ! + ! Some algebra was needed to find this equation, essentially combining (TC81-26) and ! + ! (TC81-27), and the conservation of total water (TC81-16). It assumes that the divi- ! + ! sion between the three phases is already taken care of. ! + ! Iterative procedure is needed, and here we iterate looking for T(LCL). Theta_il ! + ! can be rewritten in terms of T(LCL) only, and once we know this thetae_iv becomes ! + ! straightforward. T(LCL) will be found using Newton's method, and in the unlikely ! + ! event it fails,we will fall back to the modified regula falsi (Illinois method). ! + ! ! ! Important remarks: ! - ! 1. If you don't want to use ice thermodynamics, simply force useice to be .false. ! - ! Otherwise, the model will decide based on the LEVEL given by the user from their ! - ! RAMSIN. ! - ! 2. If rtot < rsat, then this will convert theta_e into theta, which can be thought as ! - ! a particular case. ! + ! 1. TLCL and PLCL are the actual TLCL and PLCL, so in case condensation exists, they ! + ! will be larger than the actual temperature and pressure (because one would go down ! + ! to reach the equilibrium); ! + ! 2. DZLCL WILL BE SET TO ZERO in case the LCL is beneath the starting level. So in ! + ! case you want to force TLCL <= TEMP and PLCL <= PRES, you can use this variable ! + ! to run the saturation check afterwards. DON'T CHANGE PLCL and TLCL here, they will ! + ! be used for conversions between theta_il and thetae_iv as they are defined here. ! + ! 3. In case you don't want ice, simply pass useice=.false.. Otherwise let the model ! + ! decide by itself based on the LEVEL variable. ! !---------------------------------------------------------------------------------------! - real function thetaeiv2thil(theiv,pres,rtot,useice) - use rconstants, only : alvl,cp,ep,p00,rocp,ttripoli,t3ple,t00 + subroutine lcl_il(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl,useice) + use rconstants , only : cpog & ! intent(in) + , ep & ! intent(in) + , p00 & ! intent(in) + , rocp & ! intent(in) + , t3ple & ! intent(in) + , t00 ! ! intent(in) implicit none - !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: theiv ! Ice vapour equiv. pot. temp. [ K] - real , intent(in) :: pres ! Pressure [ Pa] - real , intent(in) :: rtot ! Total mixing ratio [ kg/kg] - logical, intent(in), optional :: useice ! Flag for considering ice thermo [ T|F] - !----- Local variables for iterative method -----------------------------------------! - real :: pvap ! Sat. vapour pressure - real :: theta ! Potential temperature - real :: deriv ! Function derivative - real :: funnow ! Function for which we seek a root. - real :: funa ! Smallest guess function - real :: funz ! Largest guess function - real :: tlcla ! Smallest guess (or old guess in Newton) - real :: tlclz ! Largest guess (or new guess in Newton) - real :: tlcl ! What will be the LCL temperature - real :: es00 ! Defined as p00*rt/(epsilon + rt) - real :: delta ! Aux. variable (For 2nd guess). - integer :: itn,itb ! Iteration counters - integer :: ii ! Another counter - logical :: converged ! Convergence handle - logical :: zside ! Aux. flag - check sides for Regula Falsi - logical :: brrr_cold ! Flag - considering ice thermo. - !------------------------------------------------------------------------------------! - - !----- Filling the flag for ice thermo that will be always present ------------------! + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: thil ! Ice liquid pot. temp. (*)[ K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + real(kind=4), intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] + real(kind=4), intent(out) :: tlcl ! LCL temperature [ K] + real(kind=4), intent(out) :: plcl ! LCL pressure [ Pa] + real(kind=4), intent(out) :: dzlcl ! Sub-LCL layer thickness [ m] + !------------------------------------------------------------------------------------! + ! (*) This is the most general variable. Thil is exactly theta for no condensation ! + ! condition, and it is the liquid potential temperature if no ice is present. ! + !------------------------------------------------------------------------------------! + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in) , optional :: useice ! May use ice thermodyn.? [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: pvap ! Sat. vapour pressure + real(kind=4) :: deriv ! Function derivative + real(kind=4) :: funnow ! Current function evaluation + real(kind=4) :: funa ! Smallest guess function + real(kind=4) :: funz ! Largest guess function + real(kind=4) :: tlcla ! Smallest guess (Newton: previous) + real(kind=4) :: tlclz ! Largest guess (Newton: new) + real(kind=4) :: es00 ! Defined as p00*rt/(epsilon + rt) + real(kind=4) :: delta ! Aux. variable for bisection + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + logical :: converged ! Convergence flag + logical :: zside ! Flag to check sides + logical :: frozen ! Will use ice thermodyn. [ T|F] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Check whether ice thermodynamics is the way to go. ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice - else - brrr_cold = bulk_on + frozen = useice + else + frozen = bulk_on end if - - !----- Finding es00, which is a constant --------------------------------------------! - es00 = p00 * rtot / (ep+rtot) - + !------------------------------------------------------------------------------------! !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & ! 'NEWTON: it=',itn,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funnow & ! ,'deriv=',deriv !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - converged = abs(tlcla-tlclz) < toler * tlclz - if (funnow == 0.) then - tlcl = tlclz + !---------------------------------------------------------------------------------! + ! Check for convergence. ! + !---------------------------------------------------------------------------------! + converged = abs(tlcla-tlclz) < toler*tlclz + if (converged) then + !----- Guesses are almost identical, average them. ----------------------------! + tlcl = 0.5*(tlcla+tlclz) funz = funnow - converged = .true. exit newloop - elseif (converged) then - tlcl = 0.5*(tlcla+tlclz) + !------------------------------------------------------------------------------! + elseif (funnow == 0.) then + !----- We've hit the answer by luck, copy the answer. -------------------------! + tlcl = tlclz funz = funnow + converged = .true. exit newloop + !------------------------------------------------------------------------------! end if end do newloop + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! Check whether Newton's method has converged. ! !------------------------------------------------------------------------------------! if (.not. converged) then - !----- Set funz, and check whether funa and funz already have opposite sign. -----! - funz = funnow - zside=.true. - if (funa*funnow > 0.) then + !---------------------------------------------------------------------------------! + ! Newton's method has failed. We use regula falsi instead. First, we must ! + ! find two guesses whose function evaluations have opposite signs. ! + !---------------------------------------------------------------------------------! + if (funa*funnow < 0. ) then + !----- We already have two good guesses. --------------------------------------! + funz = funnow + zside = .true. + !------------------------------------------------------------------------------! + else + !------------------------------------------------------------------------------! + ! We need to find another guess with opposite sign. ! + !------------------------------------------------------------------------------! + !----- We fix funa, and try a funz that will work as 2nd guess ----------------! - if (abs(funz-funa) < toler*tlcla) then + if (abs(funnow-funa) < toler*tlcla) then delta = 100.*toler*tlcla else - delta = max(abs(funa*(tlclz-tlcla)/(funz-funa)),100.*toler*tlcla) + delta = max(abs(funa*(tlclz-tlcla)/(funnow-funa)),100.*toler*tlcla) end if tlclz = tlcla + delta + !------------------------------------------------------------------------------! !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & ! '2NGGSS: tt=',itb,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funz & ! ,'delta=',delta !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - - zside = funa*funz < 0 + zside = funa*funz < 0.0 if (zside) exit zgssloop end do zgssloop if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theiv =',theiv ,'rtot =',rtot - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'pres =',pres ,'pvap =',pvap - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theta =',theta ,'delta =',delta - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlcla =',tlcla ,'funa =',funa - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlclz =',tlclz ,'funz =',funz - call abort_run('Failed finding the second guess for regula falsi' & - ,'thetaeiv2thil','therm_lib.f90') + write (unit=*,fmt='(a)') ' ====== No second guess for you... ======' + write (unit=*,fmt='(a)') ' + INPUT variables: ' + write (unit=*,fmt='(a,1x,es14.7)') 'THIL =',thil + write (unit=*,fmt='(a,1x,es14.7)') 'TEMP =',temp + write (unit=*,fmt='(a,1x,es14.7)') 'PRES =',pres + write (unit=*,fmt='(a,1x,es14.7)') 'RTOT =',rtot + write (unit=*,fmt='(a,1x,es14.7)') 'RVAP =',rvap + write (unit=*,fmt='(a)') ' ============ Failed guess... ===========' + write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLA =',tlcla,'FUNA =',funa + write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLZ =',tlclz,'FUNC =',funz + write (unit=*,fmt='(2(a,1x,es14.7))') 'DELTA =',delta,'FUNN =',funnow + call abort_run ('Failed finding the second guess for regula falsi' & + ,'lcl_il','therm_lib.f90') end if end if - !---- Continue iterative method --------------------------------------------------! - fpoloop: do itb=itn+1,maxfpo + !---------------------------------------------------------------------------------! - !----- Updating the guess -----------------------------------------------------! - tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) - !----- Updating function evaluation -------------------------------------------! - pvap = eslif(tlcl,brrr_cold) - theta = tlcl * (es00/pvap)**rocp - funnow = thetaeivs(theta,tlcl,rtot,0.,0.) - theiv + !---------------------------------------------------------------------------------! + ! We have the guesses, solve the regula falsi method. ! + !---------------------------------------------------------------------------------! + fpoloop: do itb=itn+1,maxfpo + !----- Update guess and function evaluation. ----------------------------------! + tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) + pvap = eslif(tlcl,frozen) + funnow = tlcl * (es00/pvap)**rocp - thil + !------------------------------------------------------------------------------! !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=36,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + !write (unit=21,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),3(a,1x,es11.4,1x))') & ! 'ANSWER: itb=',itn,'tlcl=',tlcl-t00,'eslcl=',0.01*pvap & - ! ,'thil=',thetaeiv2thil,'funa=',funa,'funz=',funz - !write (unit=36,fmt='(a)') '-------------------------------------------------------' - !write (unit=36,fmt='(a)') ' ' + ! ,'dzlcl=',dzlcl,'plcl=',plcl*0.01,'funa=',funa,'funz=',funz + !write (unit=21,fmt='(a)') '-------------------------------------------------------' + !write (unit=21,fmt='(a)') ' ' !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! else - write (unit=*,fmt='(60a1)') ('-',ii=1,60) - write (unit=*,fmt='(a)') ' THEIV2THIL failed!' - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' -> Input: ' - write (unit=*,fmt='(a,1x,f12.5)') ' THEIV [ K]:',theiv - write (unit=*,fmt='(a,1x,f12.5)') ' PRES [ Pa]:',pres * 100. - write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1000.*rtot - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' -> Output: ' - write (unit=*,fmt='(a,1x,i12)') ' ITERATIONS :',itb - write (unit=*,fmt='(a,1x,f12.5)') ' PVAP [ hPa]:',pvap - write (unit=*,fmt='(a,1x,f12.5)') ' THETA [ K]:',theta - write (unit=*,fmt='(a,1x,f12.5)') ' TLCL [ °C]:',tlcl-t00 - write (unit=*,fmt='(a,1x,f12.5)') ' TLCLA [ °C]:',tlcla-t00 - write (unit=*,fmt='(a,1x,f12.5)') ' TLCLZ [ °C]:',tlclz-t00 - write (unit=*,fmt='(a,1x,es12.5)') ' FUNA [ K]:',funa - write (unit=*,fmt='(a,1x,es12.5)') ' FUNZ [ K]:',funz - write (unit=*,fmt='(a,1x,es12.5)') ' DERIV [ ---]:',deriv - write (unit=*,fmt='(a,1x,es12.5)') ' ERR_A [ ---]:',abs(tlcl-tlcla)/tlcl - write (unit=*,fmt='(a,1x,es12.5)') ' ERR_Z [ ---]:',abs(tlcl-tlclz)/tlcl - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(60a1)') ('-',ii=1,60) - - call abort_run('TLCL didn''t converge, gave up!' & - ,'thetaeiv2thil','therm_lib.f90') + write (unit=*,fmt='(a)') '-------------------------------------------------------' + write (unit=*,fmt='(a)') ' LCL Temperature didn''t converge!!!' + write (unit=*,fmt='(a,1x,i5,1x,a)') ' I gave up, after',maxfpo,'iterations...' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input values.' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a,1x,f12.4)' ) 'theta_il [ K] =',thil + write (unit=*,fmt='(a,1x,f12.4)' ) 'Pressure [ hPa] =',0.01*pres + write (unit=*,fmt='(a,1x,f12.4)' ) 'Temperature [ °C] =',temp-t00 + write (unit=*,fmt='(a,1x,f12.4)' ) 'rtot [ g/kg] =',1000.*rtot + write (unit=*,fmt='(a,1x,f12.4)' ) 'rvap [ g/kg] =',1000.*rvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Last iteration outcome.' + write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcla [ °C] =',tlcla-t00 + write (unit=*,fmt='(a,1x,f12.4)' ) 'tlclz [ °C] =',tlclz-t00 + write (unit=*,fmt='(a,1x,f12.4)' ) 'fun [ K] =',funnow + write (unit=*,fmt='(a,1x,f12.4)' ) 'funa [ K] =',funa + write (unit=*,fmt='(a,1x,f12.4)' ) 'funz [ K] =',funz + write (unit=*,fmt='(a,1x,f12.4)' ) 'deriv [ ----] =',deriv + write (unit=*,fmt='(a,1x,es12.4)') 'toler [ ----] =',toler + write (unit=*,fmt='(a,1x,es12.4)') 'error [ ----] =' & + ,abs(tlclz-tlcla)/tlclz + write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcl [ °C] =',tlcl + call abort_run ('TLCL didn''t converge, gave up!','lcl_il','therm_lib.f90') end if - return - end function thetaeiv2thil + end subroutine lcl_il !=======================================================================================! !=======================================================================================! @@ -2555,137 +4325,317 @@ end function thetaeiv2thil !=======================================================================================! !=======================================================================================! - ! This subroutine converts saturated ice-vapour equivalent potential temperature ! - ! into temperature, given pressure in Pa, and theta_es in Kelvin. It also returns the ! - ! potential temperature in Kelvin, and saturation vapour mixing ratio in kg/kg. As ! - ! usual, we seek T using Newton's method as a starting point, and if it fails, we fall ! - ! back to the modified regula falsi (Illinois method). ! - ! ! - ! OBS: In case you want to ignore ice, send useice as false. The default is to consider ! - ! when level >= 3 and to ignore otherwise. ! + ! This subroutine computes a consistent set of temperature and condensated phases ! + ! mixing ratio for a given theta_il, Exner function, and total mixing ratio. This is ! + ! very similar to the function thil2temp, except that now we don't know rliq and rice, ! + ! and for this reason they also become functions of temperature, since they are defined ! + ! as rtot-rsat(T,p), remembering that rtot and p are known. If the air is not ! + ! saturated, we rather use the fact that theta_il = theta and skip the hassle. ! + ! Otherwise, we use iterative methods. We will always try Newton's method, since it ! + ! converges fast. The caveat is that Newton may fail, and it actually does fail very ! + ! close to the triple point, because the saturation vapour pressure function has a ! + ! "kink" at the triple point (continuous, but not differentiable). If that's the case, ! + ! then we fall back to a modified regula falsi (Illinois) method, which is a mix of ! + ! secant and bisection and will converge. ! !---------------------------------------------------------------------------------------! - subroutine thetaeivs2temp(theivs,pres,theta,temp,rsat,useice) - use rconstants, only : alvl,cp,ep,p00,rocp,ttripoli,t00 + subroutine thil2tqall(thil,exner,pres,rtot,rliq,rice,temp,rvap,rsat) + use rconstants , only : cpdry & ! intent(in) + , cpdryi & ! intent(in) + , t00 & ! intent(in) + , toodry & ! intent(in) + , t3ple ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: theivs ! Sat. thetae_iv [ K] - real , intent(in) :: pres ! Pressure [ Pa] - real , intent(out) :: theta ! Potential temperature [ K] - real , intent(out) :: temp ! Temperature [ K] - real , intent(out) :: rsat ! Saturation mixing ratio [ kg/kg] - logical, intent(in) , optional :: useice ! Flag for considering ice [ T|F] - !----- Local variables, with other thermodynamic properties -------------------------! - real :: exnernormi ! 1./ (Norm. Exner function) [ ---] - logical :: brrr_cold ! Flag for ice thermo [ T|F] - !----- Local variables for iterative method -----------------------------------------! - real :: deriv ! Function derivative - real :: funnow ! Function for which we seek a root. - real :: funa ! Smallest guess function - real :: funz ! Largest guess function - real :: tempa ! Smallest guess (or previous in Newton) - real :: tempz ! Largest guess (or new in Newton) - real :: delta ! Aux. variable for 2nd guess finding. - integer :: itn,itb ! Iteration counters - logical :: converged ! Convergence handle - logical :: zside ! Aux. flag, check sides (Regula Falsi) - !------------------------------------------------------------------------------------! - - !----- Setting up the ice check, in case useice is not present. ---------------------! - if (present(useice)) then - brrr_cold = useice - else - brrr_cold = bulk_on + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: thil ! Ice-liquid water potential temp. [ K] + real(kind=4), intent(in) :: exner ! Exner function [J/kg/K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + real(kind=4), intent(out) :: rliq ! Liquid water mixing ratio [ kg/kg] + real(kind=4), intent(out) :: rice ! Ice mixing ratio [ kg/kg] + real(kind=4), intent(inout) :: temp ! Temperature [ K] + real(kind=4), intent(out) :: rvap ! Water vapour mixing ratio [ kg/kg] + real(kind=4), intent(out) :: rsat ! Sat. water vapour mixing ratio [ kg/kg] + !----- Local variables --------------------------------------------------------------! + real(kind=4) :: tempa ! Lower bound for regula falsi iteration + real(kind=4) :: tempz ! Upper bound for regula falsi iteration + real(kind=4) :: t1stguess ! Book keeping temperature 1st guess + real(kind=4) :: fun1st ! Book keeping 1st guess function + real(kind=4) :: funa ! Function evaluation at tempa + real(kind=4) :: funz ! Function evaluation at tempz + real(kind=4) :: funnow ! Function at this iteration. + real(kind=4) :: delta ! Aux. var in case we need regula falsi. + real(kind=4) :: deriv ! Derivative of this function. + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + integer :: ii ! Iteration counter + logical :: converged ! Convergence handle + logical :: zside ! Aux. Flag, for two purposes: + ! 1. Found a 2nd guess for regula falsi. + ! 2. I retained the "zside" (T/F) + !------------------------------------------------------------------------------------! + + t1stguess = temp + + !------------------------------------------------------------------------------------! + ! First check: try to find temperature assuming sub-saturation and check if ! + ! this is the case. If it is, then there is no need to go through the iterative ! + ! loop. ! + !------------------------------------------------------------------------------------! + tempz = cpdryi * thil * exner + rsat = max(toodry,rslif(pres,tempz)) + if (tempz >= t3ple) then + rliq = max(0.,rtot-rsat) + rice = 0. + else + rice = max(0.,rtot-rsat) + rliq = 0. end if - - !----- Finding the inverse of normalised Exner, which is constant in this routine ---! - exnernormi = (p00 /pres) ** rocp + rvap = rtot-rliq-rice + !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! - ! The 1st. guess, no idea, guess 0°C. ! + ! If rtot < rsat, this is not saturated, we can leave the subroutine and bypass ! + ! the iterative part. ! !------------------------------------------------------------------------------------! - tempz = t00 - theta = tempz * exnernormi - rsat = rslif(pres,tempz,brrr_cold) - funnow = thetaeivs(theta,tempz,rsat,0.,0.) - deriv = dthetaeivs_dt(funnow,tempz,pres,rsat,brrr_cold) - funnow = funnow - theivs + if (rtot < rsat) then + temp = tempz + return + end if - !----- Saving here just in case Newton is aborted at the 1st guess ------------------! - tempa = tempz - funa = funnow + !------------------------------------------------------------------------------------! + ! If not, then use the temperature the user gave as first guess and solve ! + ! iteratively. We use the user instead of what we just found because if the air is ! + ! saturated, then this can be too far off which may be bad for Newton's method. ! + !------------------------------------------------------------------------------------! + tempz = temp + rsat = max(toodry,rslif(pres,tempz)) + if (tempz >= t3ple) then + rliq = max(0.,rtot-rsat) + rice = 0. + else + rice = max(0.,rtot-rsat) + rliq = 0. + end if + rvap = rtot-rliq-rice - converged = .false. - !----- Looping ----------------------------------------------------------------------! + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>= t3ple) then + rliq = max(0.,rtot-rsat) + rice = 0. + else + rice = max(0.,rtot-rsat) + rliq = 0. + end if + rvap = rtot-rliq-rice + !----- Updating the function -----------------------------------------------------! + funnow = theta_iceliq(exner,tempz,rliq,rice) + !----- Updating the derivative. --------------------------------------------------! + deriv = dthetail_dt(.false.,funnow,exner,pres,tempz,rliq,rice) + funnow = funnow - thil + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=46,fmt='(a,1x,i5,1x,6(a,1x,f11.4,1x),a,1x,es11.4,1x)') & + ! 'NEWTON: it=',itn,'temp=',tempz-t00,'rsat=',1000.*rsat,'rliq=',1000.*rliq & + ! ,'rice=',1000.*rice,'rvap=',1000.*rvap,'fun=',funnow,'deriv=',deriv + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + converged = abs(tempa-tempz) < toler*tempz + !---------------------------------------------------------------------------------! + ! Convergence. The temperature will be the mid-point between tempa and tempz. ! + ! Fix the mixing ratios and return. But first check for converged due to luck. If ! + ! the guess gives a root, then that's it. It looks unlikely, but it actually ! + ! happens sometimes and if not checked it becomes a singularity. ! + !---------------------------------------------------------------------------------! if (funnow == 0.) then - converged =.true. temp = tempz + converged = .true. exit newloop elseif (converged) then - temp = 0.5*(tempa+tempz) + temp = 0.5 * (tempa+tempz) + rsat = max(toodry,rslif(pres,temp)) + if (temp >= t3ple) then + rliq = max(0.,rtot-rsat) + rice = 0. + else + rice = max(0.,rtot-rsat) + rliq = 0. + end if + rvap = rtot-rliq-rice exit newloop end if - end do newloop + end do newloop !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! - !------------------------------------------------------------------------------------! + + !----- For debugging only -----------------------------------------------------------! + itb = itn+1 + if (.not. converged) then - !----- Set funz, and check whether funa and funz already have opposite sign. -----! - funz = funnow - zside = .false. - if (funa*funnow > 0.) then - !----- We fix funa, and try a funz that will work as 2nd guess ----------------! - if (abs(funz-funa) < toler*tempa) then + !---------------------------------------------------------------------------------! + ! If I reach this point, then it means that Newton's method failed finding the ! + ! equilibrium, so we are going to use the regula falsi instead. If Newton's ! + ! method didn't converge, we use tempa as one guess and now we seek a tempz with ! + ! opposite sign. ! + !---------------------------------------------------------------------------------! + !----- Check funa and funnow have opposite signs. If so, we are ready to go ------! + if (funa*funnow < 0.0) then + funz = funnow + zside = .true. + !----- Otherwise, checking whether the 1st guess had opposite sign. --------------! + elseif (funa*fun1st < 0.0) then + funz = fun1st + zside = .true. + !---------------------------------------------------------------------------------! + ! Looking for a guess. Extrapolate funa linearly, trying to get the -funa. We ! + ! don't need it to be funa, just with the opposite sign. If that's not enough, ! + ! we keep going further... Force the guesses to be at least 1K apart ! + !---------------------------------------------------------------------------------! + else + if (abs(funnow-funa) < 100.*toler*tempa) then delta = 100.*toler*tempa else - delta = max(abs(funa*(tempz-tempa)/(funz-funa)),100.*toler*tempa) + delta = max(abs(funa)*abs((tempz-tempa)/(funnow-funa)),100.*toler*tempa) end if tempz = tempa + delta + funz = funa + !----- Just to enter at least once. The 1st time tempz=tempa-2*delta ----------! + zside = .false. zgssloop: do itb=1,maxfpo - !----- So this will be +1 -1 +2 -2 etc. ------------------------------------! - tempz = tempz + real((-1)**itb * (itb+3)/2) * delta - theta = tempz * exnernormi - rsat = rslif(pres,tempz,brrr_cold) - funz = thetaeivs(theta,tempz,rsat,0.,0.) - theivs - zside = funa*funz < 0 - if (zside) exit zgssloop + tempz = tempa + real((-1)**itb * (itb+3)/2) * delta + rsat = max(toodry,rslif(pres,tempz)) + if (tempz >= t3ple) then + rliq = max(0.,rtot-rsat) + rice = 0. + else + rice = max(0.,rtot-rsat) + rliq = 0. + end if + rvap = rtot-rliq-rice + funz = theta_iceliq(exner,tempz,rliq,rice) - thil + zside = funa*funz < 0.0 + if (zside) exit zgssloop end do zgssloop - if (.not. zside) & - call abort_run('Failed finding the second guess for regula falsi' & - ,'thetaes2temp','therm_lib.f90') + if (.not. zside) then + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + write (unit=*,fmt='(a)') ' THIL2TQALL: NO SECOND GUESS FOR YOU!' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Input: ' + write (unit=*,fmt='(a,1x,f12.5)') ' THETA_IL [ K]:',thil + write (unit=*,fmt='(a,1x,f12.5)') ' PRESS [ hPa]:',0.01*pres + write (unit=*,fmt='(a,1x,f12.5)') ' EXNER [J/kg/K]:',exner + write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1000.*rtot + write (unit=*,fmt='(a,1x,f12.5)') ' T1ST [ degC]:',t1stguess-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPA [ degC]:',tempa-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPZ [ degC]:',tempz-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' FUNNOW [ K]:',funnow + write (unit=*,fmt='(a,1x,f12.5)') ' FUNA [ K]:',funa + write (unit=*,fmt='(a,1x,f12.5)') ' FUNZ [ K]:',funz + write (unit=*,fmt='(a,1x,f12.5)') ' DELTA [ K]:',delta + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + + call abort_run ('Failed finding the second guess for regula falsi' & + ,'thil2tqall','therm_lib.f90') + end if end if - !---- Continue iterative method --------------------------------------------------! - fpoloop: do itb=itn+1,maxfpo - if (abs(funz-funa) < toler*tempa) then - temp = 0.5*(tempa+tempz) + !---------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------! + ! Now we loop until convergence is achieved. One important thing to notice ! + ! is that Newton's method fail only when T is almost T3ple, which means that ice ! + ! and liquid should be present, and we are trying to find the saturation point ! + ! with all ice or all liquid. This will converge but the final answer will ! + ! contain significant error. To reduce it we redistribute the condensates between ! + ! ice and liquid conserving the total condensed mixing ratio. ! + !---------------------------------------------------------------------------------! + fpoloop: do itb=itn,maxfpo + temp = (funz*tempa-funa*tempz)/(funz-funa) + !----- Checking whether this guess will fall outside the range ----------------! + if (abs(temp-tempa) > abs(tempz-tempa) .or. & + abs(temp-tempz) > abs(tempz-tempa)) then + temp = 0.5*(tempa+tempz) + end if + !----- Distributing vapour into the three phases ------------------------------! + rsat = max(toodry,rslif(pres,temp)) + rvap = min(rtot,rsat) + if (temp >= t3ple) then + rliq = max(0.,rtot-rsat) + rice = 0. else - temp = (funz*tempa-funa*tempz)/(funz-funa) + rliq = 0. + rice = max(0.,rtot-rsat) end if - theta = temp * exnernormi - rsat = rslif(pres,temp,brrr_cold) - funnow = thetaeivs(theta,temp,rsat,0.,0.) - theivs + !----- Updating function ------------------------------------------------------! + funnow = theta_iceliq(exner,temp,rliq,rice) - thil + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> Input: ' + write (unit=*,fmt='(a,1x,f12.5)') ' THETA_IL [ K]:',thil + write (unit=*,fmt='(a,1x,f12.5)') ' EXNER [J/kg/K]:',exner + write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1000.*rtot + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Output: ' + write (unit=*,fmt='(a,1x,i12)') ' ITERATIONS :',itb + write (unit=*,fmt='(a,1x,f12.5)') ' TEMP [ °C]:',temp-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' RVAP [ g/kg]:',1000.*rvap + write (unit=*,fmt='(a,1x,f12.5)') ' RLIQ [ g/kg]:',1000.*rliq + write (unit=*,fmt='(a,1x,f12.5)') ' RICE [ g/kg]:',1000.*rice + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPA [ °C]:',tempa-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPZ [ °C]:',tempz-t00 + write (unit=*,fmt='(a,1x,es12.5)') ' FUNA [ K]:',funnow + write (unit=*,fmt='(a,1x,es12.5)') ' FUNZ [ K]:',funnow + write (unit=*,fmt='(a,1x,es12.5)') ' DERIV [ ---]:',deriv + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_A [ ---]:',abs(temp-tempa)/temp + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_Z [ ---]:',abs(temp-tempz)/temp + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + call abort_run ('Failed finding equilibrium, I gave up!','thil2tqall' & + ,'therm_lib.f90') + end if + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & - ! 'NEWTON: it=',itn,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funnow & - ! ,'deriv=',deriv - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !----- Go to bisection if the derivative is too flat (too dangerous...) ----------! + if (abs(deriv) < toler) exit newloop - !------------------------------------------------------------------------------! - ! Convergence may happen when we get close guesses. ! - !------------------------------------------------------------------------------! - converged = abs(tlcla-tlclz) < toler*tlclz - if (converged) then - tlcl = 0.5*(tlcla+tlclz) - funz = funnow - exit newloop - elseif (funnow == 0.) then - tlcl = tlclz - funz = funnow + tempz = tempa - funnow / deriv + + !----- Finding the mixing ratios associated with this guess ----------------------! + rsat = max(toodry,rslf(pres,tempz)) + rliq = max(0.,rtot-rsat) + rvap = rtot-rliq + + !----- Updating the function -----------------------------------------------------! + funnow = theta_iceliq(exner,tempz,rliq,0.) + !----- Updating the derivative. --------------------------------------------------! + deriv = dthetail_dt(.false.,funnow,exner,pres,tempz,rliq) + funnow = funnow - thil + + converged = abs(tempa-tempz) < toler*tempz + !---------------------------------------------------------------------------------! + ! Convergence. The temperature will be the mid-point between tempa and tempz. ! + ! Fix the mixing ratios and return. But first check for converged due to luck. If ! + ! the guess gives a root, then that's it. It looks unlikely, but it actually ! + ! happens sometimes and if not checked it becomes a singularity. ! + !---------------------------------------------------------------------------------! + if (funnow == 0.) then + temp = tempz converged = .true. exit newloop + elseif (converged) then + temp = 0.5 * (tempa+tempz) + rsat = max(toodry,rslf(pres,temp)) + rliq = max(0.,rtot-rsat) + rvap = rtot-rliq + exit newloop end if + !---------------------------------------------------------------------------------! end do newloop + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! if (.not. converged) then !---------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using re- ! - ! gula falsi instead. First, I need to find two guesses that give me functions ! - ! with opposite signs. If funa and funnow have opposite signs, then we are all ! - ! set. ! + ! If I reach this point, then it means that Newton's method failed finding the ! + ! equilibrium, so we are going to use the regula falsi instead. If Newton's ! + ! method didn't converge, we use tempa as one guess and now we seek a tempz with ! + ! opposite sign. ! !---------------------------------------------------------------------------------! - if (funa*funnow < 0. ) then - funz = funnow + !----- Check funa and funnow have opposite signs. If so, we are ready to go ------! + if (funa*funnow < 0.0) then + funz = funnow zside = .true. - !----- They have the same sign, seeking the other guess --------------------------! + !---------------------------------------------------------------------------------! + ! Looking for a guess. Extrapolate funa linearly, trying to get the -funa. We ! + ! don't need it to be funa, just with the opposite sign. If that's not enough, ! + ! we keep going further... Force the guesses to be at least 1K apart ! + !---------------------------------------------------------------------------------! else - - !----- We fix funa, and try a funz that will work as 2nd guess ----------------! - if (abs(funnow-funa) < toler*tlcla) then - delta = 100.*toler*tlcla + if (abs(funnow-funa) < toler*tempa) then + delta = 100.*toler*tempa else - delta = max(abs(funa*(tlclz-tlcla)/(funnow-funa)),100.*toler*tlcla) + delta = max(abs(funa*(tempz-tempa)/(funnow-funa)),100.*toler*tempa) end if - tlclz = tlcla + delta - - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & - ! '2NGGSS: tt=',itb,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funz & - ! ,'delta=',delta - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - zside = funa*funz < 0 + tempz = tempz + real((-1)**itb * (itb+3)/2) * delta + rsat = max(toodry,rslf(pres,tempz)) + rliq = max(0.,rtot-rsat) + rvap = rtot-rliq + funz = theta_iceliq(exner,tempz,rliq,0.) - thil + zside = funa*funz < 0.0 if (zside) exit zgssloop end do zgssloop - if (.not. zside) then - write (unit=*,fmt='(a)') ' ====== No second guess for you... ======' - write (unit=*,fmt='(a)') ' + INPUT variables: ' - write (unit=*,fmt='(a,1x,es14.7)') 'THIL =',thil - write (unit=*,fmt='(a,1x,es14.7)') 'TEMP =',temp - write (unit=*,fmt='(a,1x,es14.7)') 'PRES =',pres - write (unit=*,fmt='(a,1x,es14.7)') 'RTOT =',rtot - write (unit=*,fmt='(a,1x,es14.7)') 'RVAP =',rvap - write (unit=*,fmt='(a,1x,i5)') 'CALL =',iflg - write (unit=*,fmt='(a)') ' ============ Failed guess... ===========' - write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLA =',tlcla,'FUNA =',funa - write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLZ =',tlclz,'FUNC =',funz - write (unit=*,fmt='(2(a,1x,es14.7))') 'DELTA =',delta,'FUNN =',funnow - call abort_run('Failed finding the second guess for regula falsi' & - ,'lcl_il','therm_lib.f90') - end if + if (.not. zside) & + call abort_run ('Failed finding the second guess for regula falsi' & + ,'thil2tqliq','rthrm.f90') end if - !---- Continue iterative method --------------------------------------------------! - fpoloop: do itb=itn+1,maxfpo - - tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) - - pvap = eslif(tlcl,brrr_cold) - - funnow = tlcl * (es00/pvap)**rocp - thil + !---------------------------------------------------------------------------------! - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=21,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),3(a,1x,es11.4,1x))') & - ! 'ANSWER: itb=',itn,'tlcl=',tlcl-t00,'eslcl=',0.01*pvap & - ! ,'dzlcl=',dzlcl,'plcl=',plcl*0.01,'funa=',funa,'funz=',funz - !write (unit=21,fmt='(a)') '-------------------------------------------------------' - !write (unit=21,fmt='(a)') ' ' - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - else - write (unit=*,fmt='(a)') '-------------------------------------------------------' - write (unit=*,fmt='(a)') ' LCL Temperature didn''t converge!!!' - write (unit=*,fmt='(a,1x,i5,1x,a)') ' I gave up, after',maxfpo,'iterations...' - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' Input values.' - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a,1x,f12.4)' ) 'theta_il [ K] =',thil - write (unit=*,fmt='(a,1x,f12.4)' ) 'Pressure [ hPa] =',0.01*pres - write (unit=*,fmt='(a,1x,f12.4)' ) 'Temperature [ °C] =',temp-t00 - write (unit=*,fmt='(a,1x,f12.4)' ) 'rtot [ g/kg] =',1000.*rtot - write (unit=*,fmt='(a,1x,f12.4)' ) 'rvap [ g/kg] =',1000.*rvap - write (unit=*,fmt='(a,1x,i5)' ) 'call [ ---] =',iflg - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' Last iteration outcome.' - write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcla [ °C] =',tlcla-t00 - write (unit=*,fmt='(a,1x,f12.4)' ) 'tlclz [ °C] =',tlclz-t00 - write (unit=*,fmt='(a,1x,f12.4)' ) 'fun [ K] =',funnow - write (unit=*,fmt='(a,1x,f12.4)' ) 'funa [ K] =',funa - write (unit=*,fmt='(a,1x,f12.4)' ) 'funz [ K] =',funz - write (unit=*,fmt='(a,1x,f12.4)' ) 'deriv [ ----] =',deriv - write (unit=*,fmt='(a,1x,es12.4)') 'toler [ ----] =',toler - write (unit=*,fmt='(a,1x,es12.4)') 'error [ ----] =' & - ,abs(tlclz-tlcla)/tlclz - write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcl [ °C] =',tlcl - call abort_run('TLCL didn''t converge, gave up!','lcl_il','therm_lib.f90') - end if + + if (.not. converged) call abort_run ('Failed finding equilibrium, I gave up!' & + ,'thil2tqliq','therm_lib.f90') return - end subroutine lcl_il + end subroutine thil2tqliq !=======================================================================================! !=======================================================================================! @@ -3031,35 +4982,48 @@ end subroutine lcl_il !=======================================================================================! !=======================================================================================! ! This subroutine computes the temperature and fraction of liquid water from the ! - ! internal energy . ! + ! intensive internal energy [J/kg]. ! !---------------------------------------------------------------------------------------! - subroutine qtk(q,tempk,fracliq) - use rconstants, only: cliqi,cicei,allii,t3ple,qicet3,qliqt3,tsupercool + subroutine uint2tl(uint,temp,fliq) + use rconstants , only : cliqi & ! intent(in) + , cicei & ! intent(in) + , allii & ! intent(in) + , t3ple & ! intent(in) + , uiicet3 & ! intent(in) + , uiliqt3 & ! intent(in) + , tsupercool_liq ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: q ! Internal energy [ J/kg] - real, intent(out) :: tempk ! Temperature [ K] - real, intent(out) :: fracliq ! Liquid Fraction (0-1) [ ---] + real(kind=4), intent(in) :: uint ! Internal energy [ J/kg] + real(kind=4), intent(out) :: temp ! Temperature [ K] + real(kind=4), intent(out) :: fliq ! Liquid Fraction (0-1) [ ---] !------------------------------------------------------------------------------------! - !----- Internal energy below qwfroz, all ice ---------------------------------------! - if (q <= qicet3) then - fracliq = 0. - tempk = q * cicei - !----- Internal energy, above qwmelt, all liquid ------------------------------------! - elseif (q >= qliqt3) then - fracliq = 1. - tempk = q * cliqi + tsupercool - !----- Changing phase, it must be at freezing point ---------------------------------! + !------------------------------------------------------------------------------------! + ! Compare the internal energy with the reference values to decide which phase ! + ! the water is. ! + !------------------------------------------------------------------------------------! + if (uint <= uiicet3) then + !----- Internal energy below qwfroz, all ice ------------------------------------! + fliq = 0. + temp = uint * cicei + !---------------------------------------------------------------------------------! + elseif (uint >= uiliqt3) then + !----- Internal energy, above qwmelt, all liquid ---------------------------------! + fliq = 1. + temp = uint * cliqi + tsupercool_liq + !---------------------------------------------------------------------------------! else - fracliq = (q-qicet3) * allii - tempk = t3ple - endif + !----- Changing phase, it must be at freezing point ------------------------------! + fliq = (uint - uiicet3) * allii + temp = t3ple + !---------------------------------------------------------------------------------! + end if !------------------------------------------------------------------------------------! return - end subroutine qtk + end subroutine uint2tl !=======================================================================================! !=======================================================================================! @@ -3070,64 +5034,78 @@ end subroutine qtk !=======================================================================================! !=======================================================================================! - ! This subroutine computes the temperature (Kelvin) and liquid fraction from inter- ! - ! nal energy (J/m² or J/m³), mass (kg/m² or kg/m³), and heat capacity (J/m²/K or ! - ! J/m³/K). ! + ! This subroutine computes the temperature (Kelvin) and liquid fraction from ! + ! extensive internal energy (J/m² or J/m³), water mass (kg/m² or kg/m³), and heat ! + ! capacity (J/m²/K or J/m³/K). ! !---------------------------------------------------------------------------------------! - subroutine qwtk(qw,w,dryhcap,tempk,fracliq) - use rconstants, only: cliqi,cliq,cicei,cice,allii,alli,t3ple,tsupercool + subroutine uextcm2tl(uext,wmass,dryhcap,temp,fliq) + use rconstants , only : cliqi & ! intent(in) + , cliq & ! intent(in) + , cicei & ! intent(in) + , cice & ! intent(in) + , allii & ! intent(in) + , alli & ! intent(in) + , t3ple & ! intent(in) + , tsupercool_liq ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: qw ! Internal energy [ J/m²] or [ J/m³] - real, intent(in) :: w ! Density [ kg/m²] or [ kg/m³] - real, intent(in) :: dryhcap ! Heat capacity of nonwater part [J/m²/K] or [J/m³/K] - real, intent(out) :: tempk ! Temperature [ K] - real, intent(out) :: fracliq ! Liquid fraction (0-1) [ ---] + real(kind=4), intent(in) :: uext ! Extensive internal energy [ J/m²] or [ J/m³] + real(kind=4), intent(in) :: wmass ! Water mass [ kg/m²] or [ kg/m³] + real(kind=4), intent(in) :: dryhcap ! Heat cap. of "dry" part [J/m²/K] or [J/m³/K] + real(kind=4), intent(out) :: temp ! Temperature [ K] + real(kind=4), intent(out) :: fliq ! Liquid fraction (0-1) [ ---] !----- Local variable ---------------------------------------------------------------! - real :: qwfroz ! qw of ice at triple point [ J/m²] or [ J/m³] - real :: qwmelt ! qw of liquid at triple point [ J/m²] or [ J/m³] + real(kind=4) :: uefroz ! qw of ice at triple pt. [ J/m²] or [ J/m³] + real(kind=4) :: uemelt ! qw of liq. at triple pt. [ J/m²] or [ J/m³] !------------------------------------------------------------------------------------! - !----- Converting melting heat to J/m² or J/m³ --------------------------------------! - qwfroz = (dryhcap + w*cice) * t3ple - qwmelt = qwfroz + w*alli - !------------------------------------------------------------------------------------! - - !------------------------------------------------------------------------------------! - ! This is analogous to the qtk computation, we should analyse the magnitude of ! - ! the internal energy to choose between liquid, ice, or both by comparing with our. ! - ! know boundaries. ! - !------------------------------------------------------------------------------------! - !----- Internal energy below qwfroz, all ice ---------------------------------------! - if (qw < qwfroz) then - fracliq = 0. - tempk = qw / (cice * w + dryhcap) - !----- Internal energy, above qwmelt, all liquid ------------------------------------! - elseif (qw > qwmelt) then - fracliq = 1. - tempk = (qw + w * cliq * tsupercool) / (dryhcap + w*cliq) - !------------------------------------------------------------------------------------! - ! We are at the freezing point. If water mass is so tiny that the internal ! - ! energy of frozen and melted states are the same given the machine precision, then ! - ! we assume that water content is negligible and we impose 50% frozen for ! - ! simplicity. ! + + !----- Convert melting heat to J/m² or J/m³ -----------------------------------------! + uefroz = (dryhcap + wmass * cice) * t3ple + uemelt = uefroz + wmass * alli !------------------------------------------------------------------------------------! - elseif (qwfroz == qwmelt) then - fracliq = 0.5 - tempk = t3ple + + + !------------------------------------------------------------------------------------! - ! Changing phase, it must be at freezing point. The max and min are here just to ! - ! avoid tiny deviations beyond 0. and 1. due to floating point arithmetics. ! + ! This is analogous to the uint2tl computation, we should analyse the magnitude ! + ! of the internal energy to choose between liquid, ice, or both by comparing with ! + ! the known boundaries. ! !------------------------------------------------------------------------------------! + if (uext < uefroz) then + !----- Internal energy below qwfroz, all ice ------------------------------------! + fliq = 0. + temp = uext / (cice * wmass + dryhcap) + !---------------------------------------------------------------------------------! + elseif (uext > uemelt) then + !----- Internal energy, above qwmelt, all liquid ---------------------------------! + fliq = 1. + temp = (uext + wmass * cliq * tsupercool_liq) / (dryhcap + wmass * cliq) + !---------------------------------------------------------------------------------! + elseif (uefroz == uemelt) then + !---------------------------------------------------------------------------------! + ! We are at the freezing point. If water mass is so tiny that the internal ! + ! energy of frozen and melted states are the same given the machine precision, ! + ! then we assume that water content is negligible and we impose 50% frozen for ! + ! simplicity. ! + !---------------------------------------------------------------------------------! + fliq = 0.5 + temp = t3ple + !---------------------------------------------------------------------------------! else - fracliq = min(1.,max(0.,(qw - qwfroz) * allii / w)) - tempk = t3ple + !---------------------------------------------------------------------------------! + ! Changing phase, it must be at freezing point. The max and min are here just ! + ! to avoid tiny deviations beyond 0. and 1. due to floating point arithmetics. ! + !---------------------------------------------------------------------------------! + fliq = min(1.,max(0.,(uext - uefroz) * allii / wmass)) + temp = t3ple + !---------------------------------------------------------------------------------! end if !------------------------------------------------------------------------------------! return - end subroutine qwtk + end subroutine uextcm2tl !=======================================================================================! !=======================================================================================! end module therm_lib diff --git a/BRAMS/src/lib/therm_lib8.f90 b/BRAMS/src/lib/therm_lib8.f90 index 9b5ae625d..cd77fef81 100644 --- a/BRAMS/src/lib/therm_lib8.f90 +++ b/BRAMS/src/lib/therm_lib8.f90 @@ -76,7 +76,6 @@ module therm_lib8 !---------------------------------------------------------------------------------------! - !---------------------------------------------------------------------------------------! ! These constants came from the paper in which the saturation vapour pressure is ! ! based on: ! @@ -89,27 +88,30 @@ module therm_lib8 ! what was on the original code... ! !---------------------------------------------------------------------------------------! !----- Coefficients for esat (liquid) --------------------------------------------------! - real(kind=8), dimension(0:8), parameter :: cll8 = & - (/ .6105851d+03, .4440316d+02, .1430341d+01 & - , .2641412d-01, .2995057d-03, .2031998d-05 & - , .6936113d-08, .2564861d-11, -.3704404d-13 /) + real(kind=8), dimension(0:8), parameter :: cll8 = (/ .6105851d+03, .4440316d+02 & + , .1430341d+01, .2641412d-01 & + , .2995057d-03, .2031998d-05 & + , .6936113d-08, .2564861d-11 & + , -.3704404d-13 /) !----- Coefficients for esat (ice) -----------------------------------------------------! - real(kind=8), dimension(0:8), parameter :: cii8 = & - (/ .6114327d+03, .5027041d+02, .1875982d+01 & - , .4158303d-01, .5992408d-03, .5743775d-05 & - , .3566847d-07, .1306802d-09, .2152144d-12 /) + real(kind=8), dimension(0:8), parameter :: cii8 = (/ .6114327d+03, .5027041d+02 & + , .1875982d+01, .4158303d-01 & + , .5992408d-03, .5743775d-05 & + , .3566847d-07, .1306802d-09 & + , .2152144d-12 /) !----- Coefficients for d(esat)/dT (liquid) --------------------------------------------! - real(kind=8), dimension(0:8), parameter :: dll8 = & - (/ .4443216d+02, .2861503d+01, .7943347d-01 & - , .1209650d-02, .1036937d-04, .4058663d-07 & - ,-.5805342d-10, -.1159088d-11, -.3189651d-14 /) + real(kind=8), dimension(0:8), parameter :: dll8 = (/ .4443216d+02, .2861503d+01 & + , .7943347d-01, .1209650d-02 & + , .1036937d-04, .4058663d-07 & + , -.5805342d-10, -.1159088d-11 & + , -.3189651d-14 /) !----- Coefficients for esat (ice) -----------------------------------------------------! - real(kind=8), dimension(0:8), parameter :: dii8 = & - (/ .5036342d+02, .3775758d+01, .1269736d+00 & - , .2503052d-02, .3163761d-04, .2623881d-06 & - , .1392546d-08, .4315126d-11, .5961476d-14 /) + real(kind=8), dimension(0:8), parameter :: dii8 = (/ .5036342d+02, .3775758d+01 & + , .1269736d+00, .2503052d-02 & + , .3163761d-04, .2623881d-06 & + , .1392546d-08, .4315126d-11 & + , .5961476d-14 /) !---------------------------------------------------------------------------------------! - !=======================================================================================! !=======================================================================================! @@ -124,27 +126,43 @@ module therm_lib8 ! Kelvin temperature. This expression came from MK05, equation (10). ! !---------------------------------------------------------------------------------------! real(kind=8) function eslf8(temp,l1funout,l2funout,ttfunout) - use rconstants, only : t008 + use rconstants , only : t008 ! ! intent(in) implicit none - real(kind=8), intent(in) :: temp - real(kind=8), intent(out), optional :: l1funout,ttfunout,l2funout - real(kind=8) :: l1fun,ttfun,l2fun,x + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! + real(kind=8), intent(out), optional :: l1funout ! Function for high temperatures + real(kind=8), intent(out), optional :: ttfunout ! Interpolation function + real(kind=8), intent(out), optional :: l2funout ! Function for low temperatures + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: l1fun ! + real(kind=8) :: ttfun ! + real(kind=8) :: l2fun ! + real(kind=8) :: x ! + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Choose between the old and the new thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then !----- Updated method, using MK05 ------------------------------------------------! - l1fun = l01_108(0) + l01_108(1)/temp + l01_108(2)*log(temp) + l01_108(3) * temp - l2fun = l02_108(0) + l02_108(1)/temp + l02_108(2)*log(temp) + l02_108(3) * temp - ttfun = tanh(ttt_108(1) * (temp - ttt_108(2))) - eslf8 = exp(l1fun + ttfun*l2fun) + l1fun = l01_108(0) + l01_108(1)/temp + l01_108(2)*log(temp) + l01_108(3) * temp + l2fun = l02_108(0) + l02_108(1)/temp + l02_108(2)*log(temp) + l02_108(3) * temp + ttfun = tanh(ttt_108(1) * (temp - ttt_108(2))) + eslf8 = exp(l1fun + ttfun*l2fun) + !---------------------------------------------------------------------------------! if (present(l1funout)) l1funout = l1fun if (present(l2funout)) l2funout = l2fun if (present(ttfunout)) ttfunout = ttfun else !----- Original method, using polynomial fit (FWC92) -----------------------------! - x = max(-8.d1,temp-t008) + x = max(-8.0d1,temp-t008) eslf8 = cll8(0) + x * (cll8(1) + x * (cll8(2) + x * (cll8(3) + x * (cll8(4) & + x * (cll8(5) + x * (cll8(6) + x * (cll8(7) + x * cll8(8)) )))))) + !---------------------------------------------------------------------------------! if (present(l1funout)) l1funout = eslf8 if (present(l2funout)) l2funout = eslf8 @@ -167,26 +185,41 @@ end function eslf8 ! Kelvin temperature, based on MK05 equation (7). ! !---------------------------------------------------------------------------------------! real(kind=8) function esif8(temp,iifunout) - use rconstants, only : t008 + use rconstants , only : t008 ! ! intent(in) implicit none - real(kind=8), intent(in) :: temp + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! real(kind=8), intent(out), optional :: iifunout - real(kind=8) :: iifun,x + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: iifun + real(kind=8) :: x + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Choose between the old and the new thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then + !----- Updated method, using MK05 ------------------------------------------------! - iifun = iii_78(0) + iii_78(1)/temp + iii_78(2) * log(temp) + iii_78(3) * temp - esif8 = exp(iifun) - + iifun = iii_78(0) + iii_78(1)/temp + iii_78(2) * log(temp) + iii_78(3) * temp + esif8 = exp(iifun) + !---------------------------------------------------------------------------------! + + if (present(iifunout)) iifunout=iifun else !----- Original method, using polynomial fit (FWC92) -----------------------------! - x=max(-8.d1,temp-t008) + x = max(-8.d1,temp-t008) esif8 = cii8(0) + x * (cii8(1) + x * (cii8(2) + x * (cii8(3) + x * (cii8(4) & - + x * (cii8(5) + x * (cii8(6) + x * (cii8(7) + x * cii8(8)) )))))) + + x * (cii8(5) + x * (cii8(6) + x * (cii8(7) + x * cii8(8)))))))) + !---------------------------------------------------------------------------------! if (present(iifunout)) iifunout=esif8 end if + !------------------------------------------------------------------------------------! + return end function esif8 !=======================================================================================! @@ -204,23 +237,43 @@ end function esif8 ! below or above the triple point. ! !---------------------------------------------------------------------------------------! real(kind=8) function eslif8(temp,useice) - use rconstants, only: t3ple8 + use rconstants , only : t3ple8 ! ! intent(in) implicit none + !----- Required arguments. ----------------------------------------------------------! real(kind=8), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! logical , intent(in), optional :: useice - logical :: brrr_cold + !----- Local variables. -------------------------------------------------------------! + logical :: frozen + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple8 + frozen = useice .and. temp < t3ple8 else - brrr_cold = bulk_on .and. temp < t3ple8 + frozen = bulk_on .and. temp < t3ple8 end if + !------------------------------------------------------------------------------------! + - if (brrr_cold) then - eslif8 = esif8(temp) ! Ice saturation vapour pressure + + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- Saturation vapour pressure for ice. ---------------------------------------! + eslif8 = esif8(temp) + !---------------------------------------------------------------------------------! else - eslif8 = eslf8(temp) ! Liquid saturation vapour pressure + !----- Saturation vapour pressure for liquid. ------------------------------------! + eslif8 = eslf8(temp) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return end function eslif8 @@ -238,13 +291,28 @@ end function eslif8 ! of pressure and Kelvin temperature. ! !---------------------------------------------------------------------------------------! real(kind=8) function rslf8(pres,temp) - use rconstants, only : ep8,toodry8 + use rconstants , only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pres,temp - real(kind=8) :: esl + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: esl ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- First we find the saturation vapour pressure. --------------------------------! + esl = eslf8(temp) + !------------------------------------------------------------------------------------! + - esl = eslf8(temp) + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the mixing ! + ! ratio. ! + !------------------------------------------------------------------------------------! rslf8 = max(toodry8,ep8*esl/(pres-esl)) + !------------------------------------------------------------------------------------! return end function rslf8 @@ -262,13 +330,28 @@ end function rslf8 ! pressure and Kelvin temperature. ! !---------------------------------------------------------------------------------------! real(kind=8) function rsif8(pres,temp) - use rconstants, only : ep8,toodry8 + use rconstants , only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pres,temp - real(kind=8) :: esi + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: esi ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- First we find the saturation vapour pressure. --------------------------------! + esi = esif8(temp) + !------------------------------------------------------------------------------------! - esi = esif8(temp) + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the mixing ! + ! ratio. ! + !------------------------------------------------------------------------------------! rsif8 = max(toodry8,ep8*esi/(pres-esi)) + !------------------------------------------------------------------------------------! return end function rsif8 @@ -286,28 +369,54 @@ end function rsif8 ! depending on temperature, as a function of pressure and Kelvin temperature. ! !---------------------------------------------------------------------------------------! real(kind=8) function rslif8(pres,temp,useice) - use rconstants, only: t3ple8,ep8 + use rconstants , only : t3ple8 & ! intent(in) + , ep8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pres,temp + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: pres + real(kind=8), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! logical , intent(in), optional :: useice + !----- Local variables. -------------------------------------------------------------! real(kind=8) :: esz - logical :: brrr_cold + logical :: frozen + !------------------------------------------------------------------------------------! + - !----- Checking which saturation (liquid or ice) I should use here ------------------! + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple8 + frozen = useice .and. temp < t3ple8 else - brrr_cold = bulk_on .and. temp < t3ple8 + frozen = bulk_on .and. temp < t3ple8 end if - - !----- Finding the saturation vapour pressure ---------------------------------------! - if (brrr_cold) then + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- Saturation vapour pressure for ice. ---------------------------------------! esz = esif8(temp) + !---------------------------------------------------------------------------------! else + !----- Saturation vapour pressure for liquid. ------------------------------------! esz = eslf8(temp) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the mixing ! + ! ratio. ! + !------------------------------------------------------------------------------------! rslif8 = ep8 * esz / (pres - esz) + !------------------------------------------------------------------------------------! return end function rslif8 @@ -319,6 +428,149 @@ end function rslif8 + !=======================================================================================! + !=======================================================================================! + ! This function calculates the liquid saturation specific humidity as a function of ! + ! pressure and Kelvin temperature. ! + !---------------------------------------------------------------------------------------! + real(kind=8) function qslf8(pres,temp) + use rconstants , only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: esl ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- First we find the saturation vapour pressure. --------------------------------! + esl = eslf8(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the ! + ! specific humidity. ! + !------------------------------------------------------------------------------------! + qslf8 = max(toodry8,ep8 * esl/( pres - (1.d0 - ep8) * esl) ) + !------------------------------------------------------------------------------------! + + return + end function qslf8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function calculates the ice saturation specific humidity as a function of ! + ! pressure and Kelvin temperature. ! + !---------------------------------------------------------------------------------------! + real(kind=8) function qsif8(pres,temp) + use rconstants , only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: esi ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- First we find the saturation vapour pressure. --------------------------------! + esi = esif8(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the ! + ! specific humidity. ! + !------------------------------------------------------------------------------------! + qsif8 = max(toodry8,ep8 * esi/( pres - (1.d0 - ep8) * esi) ) + !------------------------------------------------------------------------------------! + + return + end function qsif8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function calculates the saturation specific humidity, over liquid or ice ! + ! depending on temperature, as a function of pressure and Kelvin temperature. ! + !---------------------------------------------------------------------------------------! + real(kind=8) function qslif8(pres,temp,useice) + use rconstants , only : t3ple8 & ! intent(in) + , ep8 & ! intent(in) + , toodry8 ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: pres + real(kind=8), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: esz + logical :: frozen + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! + if (present(useice)) then + frozen = useice .and. temp < t3ple8 + else + frozen = bulk_on .and. temp < t3ple8 + end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- Saturation vapour pressure for ice. ---------------------------------------! + esz = esif8(temp) + !---------------------------------------------------------------------------------! + else + !----- Saturation vapour pressure for liquid. ------------------------------------! + esz = eslf8(temp) + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the ! + ! specific humidity. ! + !------------------------------------------------------------------------------------! + qslif8 = max(toodry8, ep8 * esz/( pres - (1.d0 - ep8) * esz) ) + !------------------------------------------------------------------------------------! + + return + end function qslif8 + !=======================================================================================! + !=======================================================================================! + + + + + !=======================================================================================! !=======================================================================================! @@ -326,12 +578,28 @@ end function rslif8 ! function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! real(kind=8) function rhovsl8(temp) - use rconstants, only : rh2o8 + use rconstants , only : rh2o8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: temp - real(kind=8) :: eequ - eequ = eslf8(temp) + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: eequ ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the equilibrium (saturation) vapour pressure. ! + !------------------------------------------------------------------------------------! + eequ = eslf8(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the saturation density. ! + !------------------------------------------------------------------------------------! rhovsl8 = eequ / (rh2o8 * temp) + !------------------------------------------------------------------------------------! + return end function rhovsl8 !=======================================================================================! @@ -349,12 +617,28 @@ end function rhovsl8 ! function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! real(kind=8) function rhovsi8(temp) - use rconstants, only : rh2o8 + use rconstants , only : rh2o8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: temp - real(kind=8) :: eequ - eequ = esif8(temp) + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: eequ ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the equilibrium (saturation) vapour pressure. ! + !------------------------------------------------------------------------------------! + eequ = esif8(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the saturation density. ! + !------------------------------------------------------------------------------------! rhovsi8 = eequ / (rh2o8 * temp) + !------------------------------------------------------------------------------------! + return end function rhovsi8 !=======================================================================================! @@ -373,19 +657,35 @@ end function rhovsi8 ! temperature. ! !---------------------------------------------------------------------------------------! real(kind=8) function rhovsil8(temp,useice) - use rconstants, only : rh2o8 + use rconstants , only : rh2o8 ! ! intent(in) implicit none + !----- Required arguments. ----------------------------------------------------------! real(kind=8), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! logical , intent(in), optional :: useice + !----- Local variables. -------------------------------------------------------------! real(kind=8) :: eequ + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Pass the "useice" argument to eslif, so it may decide whether ice thermo- ! + ! dynamics is to be used. ! + !------------------------------------------------------------------------------------! if (present(useice)) then eequ = eslif8(temp,useice) else eequ = eslif8(temp) end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the saturation density. ! + !------------------------------------------------------------------------------------! rhovsil8 = eequ / (rh2o8 * temp) + !------------------------------------------------------------------------------------! return end function rhovsil8 @@ -403,24 +703,39 @@ end function rhovsil8 ! pressure with respect to temperature as a function of Kelvin temperature. ! !---------------------------------------------------------------------------------------! real(kind=8) function eslfp8(temp) - use rconstants, only: t008 + use rconstants , only : t008 ! ! intent(in) implicit none + !------ Arguments. ------------------------------------------------------------------! real(kind=8), intent(in) :: temp - real(kind=8) :: esl,l2fun,ttfun,l1prime,l2prime,ttprime,x + !------ Local variables. ------------------------------------------------------------! + real(kind=8) :: esl + real(kind=8) :: l2fun + real(kind=8) :: ttfun + real(kind=8) :: l1prime + real(kind=8) :: l2prime + real(kind=8) :: ttprime + real(kind=8) :: x + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide which function to use, based on the thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then !----- Updated method, using MK05 ------------------------------------------------! esl = eslf8(temp,l2funout=l2fun,ttfunout=ttfun) l1prime = -l01_108(1)/(temp*temp) + l01_108(2)/temp + l01_108(3) l2prime = -l02_108(1)/(temp*temp) + l02_108(2)/temp + l02_108(3) - ttprime = ttt_108(1)*(1.-ttfun*ttfun) + ttprime = ttt_108(1)*(1.d0 - ttfun*ttfun) eslfp8 = esl * (l1prime + l2prime*ttfun + l2fun*ttprime) else !----- Original method, using polynomial fit (FWC92) -----------------------------! - x=max(-8.d1,temp-t008) + x = max(-8.d1,temp-t008) eslfp8 = dll8(0) + x * (dll8(1) + x * (dll8(2) + x * (dll8(3) + x * (dll8(4) & - + x * (dll8(5) + x * (dll8(6) + x * (dll8(7) + x * dll8(8)) )))))) + + x * (dll8(5) + x * (dll8(6) + x * (dll8(7) + x * dll8(8)))))))) end if + !------------------------------------------------------------------------------------! return @@ -439,22 +754,33 @@ end function eslfp8 ! with respect to temperature as a function of Kelvin temperature. ! !---------------------------------------------------------------------------------------! real(kind=8) function esifp8(temp) - use rconstants, only: t008 + use rconstants , only : t008 ! ! intent(in) implicit none + !------ Arguments. ------------------------------------------------------------------! real(kind=8), intent(in) :: temp - real(kind=8) :: esi,iiprime,x + !------ Local variables. ------------------------------------------------------------! + real(kind=8) :: esi + real(kind=8) :: iiprime + real(kind=8) :: x + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide which function to use, based on the thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then !----- Updated method, using MK05 ------------------------------------------------! - esi = esif8(temp) - iiprime = -iii_78(1)/(temp*temp) + iii_78(2)/temp + iii_78(3) - esifp8 = esi * iiprime + esi = esif8(temp) + iiprime = -iii_78(1)/(temp*temp) + iii_78(2)/temp + iii_78(3) + esifp8 = esi * iiprime else !----- Original method, using polynomial fit (FWC92) -----------------------------! - x=max(-8.d1,temp-t008) + x = max(-8.d1,temp-t008) esifp8 = dii8(0) + x * (dii8(1) + x * (dii8(2) + x * (dii8(3) + x * (dii8(4) & - + x * (dii8(5) + x * (dii8(6) + x * (dii8(7) + x * dii8(8)) )))))) + + x * (dii8(5) + x * (dii8(6) + x * (dii8(7) + x * dii8(8)))))))) end if + !------------------------------------------------------------------------------------! return end function esifp8 @@ -473,23 +799,43 @@ end function esifp8 ! whether the temperature is below or above the triple point. ! !---------------------------------------------------------------------------------------! real(kind=8) function eslifp8(temp,useice) - use rconstants, only: t3ple8 + use rconstants , only : t3ple8 ! ! intent(in) implicit none + !------ Arguments. ------------------------------------------------------------------! real(kind=8), intent(in) :: temp + !------ Local variables. ------------------------------------------------------------! logical , intent(in), optional :: useice - logical :: brrr_cold + logical :: frozen + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple8 + frozen = useice .and. temp < t3ple8 else - brrr_cold = bulk_on .and. temp < t3ple8 + frozen = bulk_on .and. temp < t3ple8 end if + !------------------------------------------------------------------------------------! - if (brrr_cold) then - eslifp8 = esifp8(temp) ! d(Ice saturation vapour pressure)/dT + + + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- d(Saturation vapour pressure)/dT for ice. ---------------------------------! + eslifp8 = esifp8(temp) + !---------------------------------------------------------------------------------! else - eslifp8 = eslfp8(temp) ! d(Liquid saturation vapour pressure)/dT + !----- d(Saturation vapour pressure)/dT for liquid water. ------------------------! + eslifp8 = eslfp8(temp) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return end function eslifp8 @@ -509,21 +855,41 @@ end function eslifp8 ! ture. ! !---------------------------------------------------------------------------------------! real(kind=8) function rslfp8(pres,temp) - use rconstants, only: ep8 + use rconstants , only : ep8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pres,temp - real(kind=8) :: desdt,esl,pdry - - esl = eslf8(temp) - desdt = eslfp8(temp) - - pdry = pres-esl - rslfp8 = ep8 * pres * desdt / (pdry*pdry) - - return - end function rslfp8 - !=======================================================================================! - !=======================================================================================! + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: esl ! Partial pressure [ Pa] + real(kind=8) :: desdt ! Derivative of partial pressure of water [ Pa/K] + real(kind=8) :: pdry ! Partial pressure of dry air [ Pa] + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! + esl = eslf8(temp) + desdt = eslfp8(temp) + !------------------------------------------------------------------------------------! + + + !----- Find the partial pressure of dry air. ----------------------------------------! + pdry = pres-esl + !------------------------------------------------------------------------------------! + + + !----- Find the partial derivative of mixing ratio. ---------------------------------! + rslfp8 = ep8 * pres * desdt / (pdry*pdry) + !------------------------------------------------------------------------------------! + + return + end function rslfp8 + !=======================================================================================! + !=======================================================================================! @@ -538,17 +904,35 @@ end function rslfp8 ! ture. ! !---------------------------------------------------------------------------------------! real(kind=8) function rsifp8(pres,temp) - use rconstants, only: ep8 + use rconstants , only : ep8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pres,temp - real(kind=8) :: desdt,esi,pdry + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: esi ! Partial pressure [ Pa] + real(kind=8) :: desdt ! Derivative of partial pressure of water [ Pa/K] + real(kind=8) :: pdry ! Partial pressure of dry air [ Pa] + !------------------------------------------------------------------------------------! - esi = esif8(temp) - desdt = esifp8(temp) - - pdry = pres-esi - rsifp8 = ep8 * pres * desdt / (pdry*pdry) + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! + esi = esif8(temp) + desdt = esifp8(temp) + !------------------------------------------------------------------------------------! + + + !----- Find the partial pressure of dry air. ----------------------------------------! + pdry = pres-esi + !------------------------------------------------------------------------------------! + + + !----- Find the partial derivative of mixing ratio. ---------------------------------! + rsifp8 = ep8 * pres * desdt / (pdry*pdry) + !------------------------------------------------------------------------------------! return end function rsifp8 !=======================================================================================! @@ -567,23 +951,41 @@ end function rsifp8 ! ture. ! !---------------------------------------------------------------------------------------! real(kind=8) function rslifp8(pres,temp,useice) - use rconstants, only: t3ple8 + use rconstants , only: t3ple8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pres,temp - logical , intent(in), optional :: useice - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics? [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: desdt ! Derivative of vapour pressure [ Pa/K] + logical :: frozen ! Use the ice thermodynamics [ T|F] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide whether to use liquid water of ice for saturation, based on the temper- ! + ! ature and the settings. ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple8 + frozen = useice .and. temp < t3ple8 else - brrr_cold = bulk_on .and. temp < t3ple8 + frozen = bulk_on .and. temp < t3ple8 end if + !------------------------------------------------------------------------------------! + - if (brrr_cold) then - rslifp8=rsifp8(pres,temp) + !------------------------------------------------------------------------------------! + ! Call the function depending on the previous check. ! + !------------------------------------------------------------------------------------! + if (frozen) then + rslifp8 = rsifp8(pres,temp) else - rslifp8=rslfp8(pres,temp) + rslifp8 = rslfp8(pres,temp) end if + !------------------------------------------------------------------------------------! return end function rslifp8 @@ -602,14 +1004,29 @@ end function rslifp8 ! a function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! real(kind=8) function rhovslp8(temp) - use rconstants, only : rh2o8 + use rconstants , only : rh2o8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: temp - real(kind=8) :: es,desdt + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: es ! Vapour pressure [ Pa] + real(kind=8) :: desdt ! Vapour pressure derivative [ Pa/K] + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! + es = eslf8(temp) + desdt = eslfp8(temp) + !------------------------------------------------------------------------------------! - es = eslf8(temp) - desdt = eslfp8(temp) + + !----- Find the partial derivative of saturation density . --------------------------! rhovslp8 = (desdt-es/temp) / (rh2o8 * temp) + !------------------------------------------------------------------------------------! return end function rhovslp8 @@ -628,14 +1045,29 @@ end function rhovslp8 ! function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! real(kind=8) function rhovsip8(temp) - use rconstants, only : rh2o8 + use rconstants , only : rh2o8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: temp - real(kind=8) :: es,desdt + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: es ! Vapour pressure [ Pa] + real(kind=8) :: desdt ! Vapour pressure derivative [ Pa/K] + !------------------------------------------------------------------------------------! + - es = esif8(temp) - desdt = esifp8(temp) - rhovsip8 = (desdt-es/temp) / (rh2o8 * temp) + + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! + es = esif8(temp) + desdt = esifp8(temp) + !------------------------------------------------------------------------------------! + + + !----- Find the partial derivative of saturation density . --------------------------! + rhovsip8 = (desdt - es/temp) / (rh2o8 * temp) + !------------------------------------------------------------------------------------! return end function rhovsip8 @@ -655,23 +1087,39 @@ end function rhovsip8 ! based on the temperature. ! !---------------------------------------------------------------------------------------! real(kind=8) function rhovsilp8(temp,useice) - use rconstants, only: t3ple8 + use rconstants , only : t3ple8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: temp - logical , intent(in), optional :: useice - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics? [ T|F] + !----- Local variables. -------------------------------------------------------------! + logical :: frozen ! Derivative of vapour pressure [ Pa/K] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide whether to use liquid water of ice for saturation, based on the temper- ! + ! ature and the settings. ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple8 + frozen = useice .and. temp < t3ple8 else - brrr_cold = bulk_on .and. temp < t3ple8 + frozen = bulk_on .and. temp < t3ple8 end if + !------------------------------------------------------------------------------------! + - if (brrr_cold) then + !------------------------------------------------------------------------------------! + ! Call the function depending on the previous check. ! + !------------------------------------------------------------------------------------! + if (frozen) then rhovsilp8 = rhovsip8(temp) else rhovsilp8 = rhovslp8(temp) end if + !------------------------------------------------------------------------------------! return end function rhovsilp8 @@ -694,65 +1142,93 @@ end function rhovsilp8 !---------------------------------------------------------------------------------------! real(kind=8) function tslf8(pvap) - implicit none - !----- Argument ---------------------------------------------------------------------! + implicit none + !----- Arguments. -------------------------------------------------------------------! real(kind=8), intent(in) :: pvap ! Saturation vapour pressure [ Pa] - !----- Local variables for iterative method -----------------------------------------! + !----- Local variables for iterative method. ----------------------------------------! real(kind=8) :: deriv ! Function derivative [ Pa] real(kind=8) :: fun ! Function for which we seek a root. [ Pa] real(kind=8) :: funa ! Smallest guess function [ Pa] real(kind=8) :: funz ! Largest guess function [ Pa] real(kind=8) :: tempa ! Smallest guess (or previous guess) [ Pa] - real(kind=8) :: tempz ! Largest guess (or new guess ) [ Pa] + real(kind=8) :: tempz ! Largest guess (new guess in Newton) [ Pa] real(kind=8) :: delta ! Aux. var --- 2nd guess for bisection [ ] - integer :: itn,itb ! Iteration counter [ ---] + integer :: itn ! Iteration counter [ ---] + integer :: itb ! Iteration counter [ ---] logical :: converged ! Convergence handle [ ---] - logical :: zside ! Flag to check for 1-sided approach. [ ---] + logical :: zside ! Flag to check for one-sided approach [ ---] !------------------------------------------------------------------------------------! - !----- First Guess, using Bolton (1980) equation 11, giving es in Pa and T in K -----! + !----- First Guess, use Bolton (1980) equation 11, giving es in Pa and T in K -------! tempa = (2.965d1 * log(pvap) - 5.01678d3)/(log(pvap)-2.40854d1) funa = eslf8(tempa) - pvap deriv = eslfp8(tempa) - !----- Copying just in case it fails at the first iteration -------------------------! + !------------------------------------------------------------------------------------! + + + !----- Copy just in case it fails at the first iteration ----------------------------! tempz = tempa fun = funa - + !------------------------------------------------------------------------------------! + + !----- Enter Newton's method loop: --------------------------------------------------! converged = .false. newloop: do itn = 1,maxfpo/6 if (abs(deriv) < toler8) exit newloop !----- Too dangerous, go with bisection ----! - !----- Copying the previous guess ------------------------------------------------! + + !----- Copy the previous guess. --------------------------------------------------! tempa = tempz funa = fun - !----- New guess, its function and derivative evaluation -------------------------! + !---------------------------------------------------------------------------------! + + + !----- New guess, its function, and derivative evaluation. -----------------------! tempz = tempa - fun/deriv fun = eslf8(tempz) - pvap deriv = eslfp8(tempz) - + !---------------------------------------------------------------------------------! + + + !----- Check convergence. --------------------------------------------------------! converged = abs(tempa-tempz) < toler8 * tempz if (converged) then tslf8 = 5.d-1 * (tempa+tempz) return - elseif (fun == 0.d0) then !Converged by luck! + elseif (fun == 0.0d0) then + !----- Converged by luck. -----------------------------------------------------! tslf8 = tempz return end if + !---------------------------------------------------------------------------------! end do newloop + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! If we have reached this point, then Newton's method has failed. Use bisection ! + ! instead. For bisection, we need two guesses whose function has opposite signs. ! !------------------------------------------------------------------------------------! if (funa * fun < 0.d0) then + !----- We already have two guesses with opposite signs. --------------------------! funz = fun zside = .true. + !---------------------------------------------------------------------------------! else - if (abs(fun-funa) < 1.d2 * toler8 * tempa) then - delta = 1.d2 * toler8 * tempa + !----- Need to find the guesses with opposite signs. -----------------------------! + if (abs(fun-funa) < 1.d2*toler8*tempa) then + delta = 1.d2*toler8*tempa else - delta = max(abs(funa * (tempz-tempa)/(fun-funa)),1.d2 * toler8 * tempa) + delta = max(abs(funa * (tempz-tempa)/(fun-funa)),1.d2*toler8*tempa) end if + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! Try guesses on both sides of the first guess, increasingly further away ! + ! until we spot a good guess. ! + !---------------------------------------------------------------------------------! tempz = tempa + delta zside = .false. zgssloop: do itb=1,maxfpo @@ -762,11 +1238,22 @@ real(kind=8) function tslf8(pvap) if (zside) exit zgssloop end do zgssloop if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempa=',tempa,'funa=',funa - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempz=',tempz,'func=',funz - call abort_run('Failed finding the second guess for regula falsi' & - ,'tslf8','therm_lib8.f90') + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the second guess:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' + call abort_run ('Failed finding the second guess for regula falsi' & + ,'tslf8','therm_lib8.f90') end if end if @@ -775,38 +1262,54 @@ real(kind=8) function tslf8(pvap) tslf8 = (funz*tempa-funa*tempz)/(funz-funa) !---------------------------------------------------------------------------------! - ! Now that we updated the guess, check whether they are really close. If so, ! + ! Now that we updated the guess, check whether they are really close. If so, ! ! it converged, I can use this as my guess. ! !---------------------------------------------------------------------------------! converged = abs(tslf8-tempa) < toler8 * tslf8 if (converged) exit bisloop - !------ Finding the new function -------------------------------------------------! + !------ Find the new function evaluation. ----------------------------------------! fun = eslf8(tslf8) - pvap + !---------------------------------------------------------------------------------! - !------ Defining my new interval based on the intermediate value theorem. --------! + + !------ Define the new interval based on the intermediate value theorem. ---------! if (fun*funa < 0.d0 ) then tempz = tslf8 funz = fun - !----- If we are updating zside again, modify aside (Illinois method) ---------! - if (zside) funa=funa * 5.d-1 - !----- We just updated zside, setting zside to true. --------------------------! + !----- If we are updating zside again, modify aside (Illinois method). --------! + if (zside) funa = funa * 5.d-1 + !----- We have just updated zside, so we set zside to true. -------------------! zside = .true. else tempa = tslf8 funa = fun - !----- If we are updating aside again, modify aside (Illinois method) ---------! - if (.not. zside) funz=funz * 5.d-1 - !----- We just updated aside, setting aside to true. --------------------------! + !----- If we are updating aside again, modify zside (Illinois method). --------! + if (.not. zside) funz = funz * 5.d-1 + !----- We have just updated aside, so we set zside to false. ------------------! zside = .false. end if end do bisloop if (.not.converged) then - call abort_run('Temperature didn''t converge, giving up!!!' & - ,'tslf8','therm_lib8.f90') + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the solution:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' + call abort_run ('Temperature didn''t converge, we give up!!!' & + ,'tslf8','therm_lib8.f90') end if - + return end function tslf8 !=======================================================================================! @@ -828,7 +1331,7 @@ end function tslf8 real(kind=8) function tsif8(pvap) implicit none - !----- Argument ---------------------------------------------------------------------! + !----- Arguments. -------------------------------------------------------------------! real(kind=8), intent(in) :: pvap ! Saturation vapour pressure [ Pa] !----- Local variables for iterative method -----------------------------------------! real(kind=8) :: deriv ! Function derivative [ Pa] @@ -836,56 +1339,81 @@ real(kind=8) function tsif8(pvap) real(kind=8) :: funa ! Smallest guess function [ Pa] real(kind=8) :: funz ! Largest guess function [ Pa] real(kind=8) :: tempa ! Smallest guess (or previous guess) [ Pa] - real(kind=8) :: tempz ! Largest guess (or new guess) [ Pa] + real(kind=8) :: tempz ! Largest guess (new guess in Newton) [ Pa] real(kind=8) :: delta ! Aux. var --- 2nd guess for bisection [ ] - integer :: itn,itb ! Iteration counter [ ---] + integer :: itn + integer :: itb ! Iteration counter [ ---] logical :: converged ! Convergence handle [ ---] logical :: zside ! Flag to check for one-sided approach [ ---] !------------------------------------------------------------------------------------! - !----- First Guess, using Murphy-Koop (2005), equation 8. ---------------------------! + !----- First Guess, use Murphy-Koop (2005), equation 8. -----------------------------! tempa = (1.814625d0 * log(pvap) +6.190134d3)/(2.9120d1 - log(pvap)) funa = esif8(tempa) - pvap deriv = esifp8(tempa) - !----- Copying just in case it fails at the first iteration -------------------------! + !------------------------------------------------------------------------------------! + + + !----- Copy just in case it fails at the first iteration ----------------------------! tempz = tempa fun = funa - + !------------------------------------------------------------------------------------! + + !----- Enter Newton's method loop: --------------------------------------------------! converged = .false. newloop: do itn = 1,maxfpo/6 if (abs(deriv) < toler8) exit newloop !----- Too dangerous, go with bisection ----! - !----- Copying the previous guess ------------------------------------------------! + + !----- Copy the previous guess. --------------------------------------------------! tempa = tempz funa = fun - !----- New guess, its function and derivative evaluation -------------------------! + + + !----- New guess, its function, and derivative evaluation. -----------------------! tempz = tempa - fun/deriv fun = esif8(tempz) - pvap deriv = esifp8(tempz) - + !---------------------------------------------------------------------------------! + + + !----- Check convergence. --------------------------------------------------------! converged = abs(tempa-tempz) < toler8 * tempz if (converged) then - tsif8 = 5.d-1*(tempa+tempz) + tsif8 = 5.d-1 * (tempa+tempz) return elseif (fun == 0.d0) then tsif8 = tempz return end if end do newloop + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! If we have reached this point, then Newton's method has failed. Use bisection ! + ! instead. For bisection, we need two guesses whose function has opposite signs. ! !------------------------------------------------------------------------------------! if (funa * fun < 0.d0) then + !----- We already have two guesses with opposite signs. --------------------------! funz = fun zside = .true. + !---------------------------------------------------------------------------------! else - if (abs(fun-funa) < 1.d2 * toler8 * tempa) then - delta = 1.d2 * toler8 * delta + !----- Need to find the guesses with opposite signs. -----------------------------! + if (abs(fun-funa) < 1.d2*toler8*tempa) then + delta = 1.d2*toler8*delta else - delta = max(abs(funa * (tempz-tempa)/(fun-funa)),1.d2 * toler8 * tempa) + delta = max(abs(funa * (tempz-tempa)/(fun-funa)),1.d2*toler8*tempa) end if + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! Try guesses on both sides of the first guess, increasingly further away ! + ! until we spot a good guess. ! + !---------------------------------------------------------------------------------! tempz = tempa + delta zside = .false. zgssloop: do itb=1,maxfpo @@ -895,11 +1423,22 @@ real(kind=8) function tsif8(pvap) if (zside) exit zgssloop end do zgssloop if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempa=',tempa,'funa=',funa - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempz=',tempz,'func=',funz - call abort_run('Failed finding the second guess for regula falsi' & - ,'tsif8','therm_lib8.f90') + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the second guess:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' + call abort_run ('Failed finding the second guess for regula falsi' & + ,'tsif8','therm_lib8.f90') end if end if @@ -908,36 +1447,53 @@ real(kind=8) function tsif8(pvap) tsif8 = (funz*tempa-funa*tempz)/(funz-funa) !---------------------------------------------------------------------------------! - ! Now that we updated the guess, check whether they are really close. If so, ! + ! Now that we updated the guess, check whether they are really close. If so, ! ! it converged, I can use this as my guess. ! !---------------------------------------------------------------------------------! converged = abs(tsif8-tempa) < toler8 * tsif8 if (converged) exit bisloop + !---------------------------------------------------------------------------------! - !------ Finding the new function -------------------------------------------------! + !------ Find the new function evaluation. ----------------------------------------! fun = esif8(tsif8) - pvap + !---------------------------------------------------------------------------------! - !------ Defining my new interval based on the intermediate value theorem. --------! - if (fun*funa < 0. ) then + + !------ Define the new interval based on the intermediate value theorem. ---------! + if (fun*funa < 0.d0 ) then tempz = tsif8 funz = fun - !----- If we are updating zside again, modify aside (Illinois method) ---------! - if (zside) funa=funa * 5.d-1 - !----- We just updated zside, setting zside to true. --------------------------! + !----- If we are updating zside again, modify aside (Illinois method). --------! + if (zside) funa = funa * 5.d-1 + !----- We have just updated zside, so we set zside to true. -------------------! zside = .true. else tempa = tsif8 funa = fun - !----- If we are updating aside again, modify aside (Illinois method) ---------! - if (.not. zside) funz=funz * 5.d-1 - !----- We just updated aside, setting aside to true. --------------------------! + !----- If we are updating aside again, modify aside (Illinois method). --------! + if (.not. zside) funz = funz * 5.d-1 + !----- We have just updated aside, so we set zside to false. ------------------! zside = .false. end if end do bisloop if (.not.converged) then - call abort_run('Temperature didn''t converge, giving up!!!' & - ,'tsif8','therm_lib8.f90') + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the solution:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' + call abort_run ('Temperature didn''t converge, we give up!!!' & + ,'tsif8','therm_lib8.f90') end if return @@ -956,29 +1512,40 @@ end function tsif8 ! This is truly the inverse of eslf and esif. ! !---------------------------------------------------------------------------------------! real(kind=8) function tslif8(pvap,useice) - use rconstants, only: es3ple8 + use rconstants , only : es3ple8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pvap - logical , intent(in), optional :: useice - logical :: brrr_cold - + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: pvap ! Vapour pressure [ Pa] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] + !----- Local variables. -------------------------------------------------------------! + logical :: frozen ! Will use ice thermodynamics [ T|F] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! - ! Since pvap is a function of temperature only, we can check the triple point ! + ! Since pvap is a function of temperature only, we can check the triple point ! ! from the saturation at the triple point, like what we would do for temperature. ! !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. pvap < es3ple8 + frozen = useice .and. pvap < es3ple8 else - brrr_cold = bulk_on .and. pvap < es3ple8 + frozen = bulk_on .and. pvap < es3ple8 end if + !------------------------------------------------------------------------------------! - if (brrr_cold) then + !------------------------------------------------------------------------------------! + ! Call the function depending on whether we should use ice. ! + !------------------------------------------------------------------------------------! + if (frozen) then tslif8 = tsif8(pvap) else tslif8 = tslf8(pvap) end if + !------------------------------------------------------------------------------------! return end function tslif8 @@ -993,19 +1560,34 @@ end function tslif8 !=======================================================================================! !=======================================================================================! ! This fucntion computes the dew point temperature given the pressure and vapour ! - ! mixing ratio. THIS IS DEWPOINT ONLY, WHICH MEANS THAT IT WILL IGNORE ICE EFFECT. For ! - ! a full, triple-point dependent routine use DEWFROSTPOINT ! + ! mixing ratio. THIS IS DEW POINT ONLY, WHICH MEANS THAT IT WILL IGNORE ICE EFFECT. For ! + ! a full, triple-point dependent routine use DEWFROSTPOINT. ! !---------------------------------------------------------------------------------------! real(kind=8) function dewpoint8(pres,rsat) - use rconstants, only: ep8,toodry8 - + use rconstants , only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pres, rsat - real(kind=8) :: rsatoff, pvsat - + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: rsatoff ! Non-singular saturation mixing ratio [ kg/kg] + real(kind=8) :: pvsat ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- Make sure mixing ratio is positive. ------------------------------------------! rsatoff = max(toodry8,rsat) - pvsat = pres*rsatoff / (ep8 + rsatoff) + !------------------------------------------------------------------------------------! + + + !----- Find the saturation vapour pressure. -----------------------------------------! + pvsat = pres * rsatoff / (ep8 + rsatoff) + !------------------------------------------------------------------------------------! + + !----- Dew point is going to be the saturation temperature. -------------------------! dewpoint8 = tslf8(pvsat) + !------------------------------------------------------------------------------------! return end function dewpoint8 @@ -1020,19 +1602,34 @@ end function dewpoint8 !=======================================================================================! !=======================================================================================! ! This fucntion computes the frost point temperature given the pressure and vapour ! - ! mixing ratio. THIS IS FROSTPOINT ONLY, WHICH MEANS THAT IT WILL IGNORE LIQUID EFFECT. ! - ! For a full, triple-point dependent routine use DEWFROSTPOINT ! + ! mixing ratio. THIS IS FROST POINT ONLY, WHICH MEANS THAT IT WILL IGNORE LIQUID ! + ! EFFECT. For a full, triple-point dependent routine use DEWFROSTPOINT. ! !---------------------------------------------------------------------------------------! real(kind=8) function frostpoint8(pres,rsat) - use rconstants, only: ep8,toodry8 - + use rconstants , only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pres, rsat - real(kind=8) :: rsatoff, pvsat - + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Local variables for iterative method. ----------------------------------------! + real(kind=8) :: rsatoff ! Non-singular saturation mixing ratio [ kg/kg] + real(kind=8) :: pvsat ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- Make sure mixing ratio is positive. ------------------------------------------! rsatoff = max(toodry8,rsat) + !------------------------------------------------------------------------------------! + + + !----- Find the saturation vapour pressure. -----------------------------------------! pvsat = pres*rsatoff / (ep8 + rsatoff) + !------------------------------------------------------------------------------------! + + !----- Frost point is going to be the saturation temperature. -----------------------! frostpoint8 = tsif8(pvsat) + !------------------------------------------------------------------------------------! return end function frostpoint8 @@ -1051,20 +1648,36 @@ end function frostpoint8 ! the triple point vapour pressure, finding dewpoint or frostpoint accordingly. ! !---------------------------------------------------------------------------------------! real(kind=8) function dewfrostpoint8(pres,rsat,useice) - use rconstants, only: ep8,toodry8 + use rconstants , only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pres, rsat - logical , intent(in), optional :: useice - real(kind=8) :: rsatoff, pvsat + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: rsatoff ! Non-singular sat. mix. rat. [ kg/kg] + real(kind=8) :: pvsat ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- Make sure mixing ratio is positive. ------------------------------------------! + rsatoff = max(toodry8,rsat) + !------------------------------------------------------------------------------------! - rsatoff = max(toodry8,rsat) + !----- Find the saturation vapour pressure. -----------------------------------------! pvsat = pres*rsatoff / (ep8 + rsatoff) + !------------------------------------------------------------------------------------! + + !----- Dew (frost) point is going to be the saturation temperature. -----------------! if (present(useice)) then dewfrostpoint8 = tslif8(pvsat,useice) else dewfrostpoint8 = tslif8(pvsat) end if + !------------------------------------------------------------------------------------! return end function dewfrostpoint8 !=======================================================================================! @@ -1077,28 +1690,52 @@ end function dewfrostpoint8 !=======================================================================================! !=======================================================================================! - ! This function computes the vapour mixing ratio based on the pressure [Pa], tem- ! - ! perature [K] and relative humidity [fraction]. IT ALWAYS ASSUME THAT RELATIVE HUMI- ! - ! DITY IS WITH RESPECT TO THE LIQUID PHASE. ptrh2rvapil checks which one to use ! - ! depending on whether temperature is more or less than the triple point. ! + ! This function computes the vapour mixing ratio (or specific humidity) based on ! + ! the pressure [Pa], temperature [K] and relative humidity [fraction]. IT ALWAYS ! + ! ASSUMES THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE LIQUID PHASE. Ptrh2rvapil ! + ! checks which one to use depending on whether temperature is more or less than the ! + ! triple point. ! !---------------------------------------------------------------------------------------! - real(kind=8) function ptrh2rvapl8(relh,pres,temp) - use rconstants, only: ep8,toodry8 - + real(kind=8) function ptrh2rvapl8(relh,pres,temp,out_shv) + use rconstants , only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: relh, pres, temp - real(kind=8) :: rsath, relhh - rsath = max(toodry8,rslf8(pres,temp)) + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: relh ! Relative humidity [ --] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + logical , intent(in) :: out_shv ! Output is specific humidity [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: pvap ! Vapour pressure [ Pa] + real(kind=8) :: relhh ! Bounded relative humidity [ --] + !------------------------------------------------------------------------------------! + + + + !---- Make sure relative humidity is bounded. ---------------------------------------! relhh = min(1.d0,max(0.d0,relh)) + !------------------------------------------------------------------------------------! - if (newthermo) then - !----- Considering that Rel.Hum. is based on vapour pressure ---------------------! - ptrh2rvapl8 = max(toodry8,ep8 * relhh * rsath / (ep8 + (1.d0-relhh)*rsath)) + + !---- Find the vapour pressure. -----------------------------------------------------! + pvap = relhh * eslf8(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Convert the output to the sought humidity variable. ! + !------------------------------------------------------------------------------------! + if (out_shv) then + !----- Specific humidity. --------------------------------------------------------! + ptrh2rvapl8 = max(toodry8, ep8 * pvap / (pres - (1.d0 - ep8) * pvap)) + !---------------------------------------------------------------------------------! else - !----- Original RAMS way to compute mixing ratio ---------------------------------! - ptrh2rvapl8 = max(toodry8,relhh*rsath) + !----- Mixing ratio. -------------------------------------------------------------! + ptrh2rvapl8 = max(toodry8, ep8 * pvap / (pres - pvap)) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return end function ptrh2rvapl8 @@ -1112,33 +1749,57 @@ end function ptrh2rvapl8 !=======================================================================================! !=======================================================================================! - ! This function computes the vapour mixing ratio based on the pressure [Pa], tem- ! - ! perature [K] and relative humidity [fraction]. IT ALWAYS ASSUME THAT RELATIVE HUMI- ! - ! DITY IS WITH RESPECT TO THE ICE PHASE. ptrh2rvapil checks which one to use depending ! - ! on whether temperature is more or less than the triple point. ! + ! This function computes the vapour mixing ratio (or specific humidity) based on ! + ! the pressure [Pa], temperature [K] and relative humidity [fraction]. IT ALWAYS ! + ! ASSUMES THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE ICE PHASE. Ptrh2rvapil ! + ! checks which one to use depending on whether temperature is more or less than the ! + ! triple point. ! !---------------------------------------------------------------------------------------! - real(kind=8) function ptrh2rvapi8(relh,pres,temp) - use rconstants, only: ep8,toodry8 - + real(kind=8) function ptrh2rvapi8(relh,pres,temp,out_shv) + use rconstants , only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: relh, pres, temp - real(kind=8) :: rsath, relhh - rsath = max(toodry8,rsif8(pres,temp)) - relhh = min(1.d0,max(0.d0,relh)) - - if (newthermo) then - !----- Considering that Rel.Hum. is based on vapour pressure ---------------------! - ptrh2rvapi8 = max(toodry8,ep8 * relhh * rsath / (ep8 + (1.d0-relhh)*rsath)) - else - !----- Original RAMS way to compute mixing ratio ---------------------------------! - ptrh2rvapi8 = max(toodry8,relhh*rsath) - end if + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: relh ! Relative humidity [ --] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + logical , intent(in) :: out_shv ! Output is specific humidity [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: pvap ! Vapour pressure [ Pa] + real(kind=8) :: relhh ! Bounded relative humidity [ --] + !------------------------------------------------------------------------------------! - return - end function ptrh2rvapi8 - !=======================================================================================! - !=======================================================================================! + + + !---- Make sure relative humidity is bounded. ---------------------------------------! + relhh = min(1.d0,max(0.d0,relh)) + !------------------------------------------------------------------------------------! + + + !---- Find the vapour pressure. -----------------------------------------------------! + pvap = relhh * esif8(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Convert the output to the sought humidity variable. ! + !------------------------------------------------------------------------------------! + if (out_shv) then + !----- Specific humidity. --------------------------------------------------------! + ptrh2rvapi8 = max(toodry8, ep8 * pvap / (pres - (1.d0 - ep8) * pvap)) + !---------------------------------------------------------------------------------! + else + !----- Mixing ratio. -------------------------------------------------------------! + ptrh2rvapi8 = max(toodry8, ep8 * pvap / (pres - pvap)) + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + return + end function ptrh2rvapi8 + !=======================================================================================! + !=======================================================================================! @@ -1147,36 +1808,67 @@ end function ptrh2rvapi8 !=======================================================================================! !=======================================================================================! - ! This function computes the vapour mixing ratio based on the pressure [Pa], tem- ! - ! perature [K] and relative humidity [fraction]. It will check the temperature to ! - ! decide between ice or liquid saturation and whether ice should be considered. ! + ! This function computes the vapour mixing ratio based (or specific humidity) based ! + ! on the pressure [Pa], temperature [K] and relative humidity [fraction]. It checks ! + ! the temperature to decide between ice or liquid saturation. ! !---------------------------------------------------------------------------------------! - real(kind=8) function ptrh2rvapil8(relh,pres,temp,useice) - use rconstants, only: ep8,toodry8,t3ple8 + real(kind=8) function ptrh2rvapil8(relh,pres,temp,out_shv,useice) + use rconstants , only : ep8 & ! intent(in) + , toodry8 & ! intent(in) + , t3ple8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: relh, pres, temp - logical , intent(in), optional :: useice - real(kind=8) :: rsath, relhh - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: relh ! Relative humidity [ --] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + logical , intent(in) :: out_shv ! Output is specific humidity [ T|F] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: pvap ! Vapour pressure [ Pa] + real(kind=8) :: relhh ! Bounded relative humidity [ --] + logical :: frozen ! Will use ice thermodynamics [ T|F] + !------------------------------------------------------------------------------------! + - !----- Checking whether I use the user or the default check for ice saturation. -----! + !----- Check whether to use the user's or the default flag for ice saturation. ------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple8 + frozen = useice .and. temp < t3ple8 else - brrr_cold = bulk_on .and. temp < t3ple8 + frozen = bulk_on .and. temp < t3ple8 end if + !------------------------------------------------------------------------------------! + - if (brrr_cold) then - rsath = max(toodry8,rsif8(pres,temp)) + + !---- Make sure relative humidity is bounded. ---------------------------------------! + relhh = min(1.d0,max(0.d0,relh)) + !------------------------------------------------------------------------------------! + + + !---- Find the vapour pressure (ice or liquid, depending on the value of frozen). ---! + if (frozen) then + pvap = relhh * esif8(temp) else - rsath = max(toodry8,rslf8(pres,temp)) + pvap = relhh * eslf8(temp) end if + !------------------------------------------------------------------------------------! - relhh = min(1.d0,max(0.d0,relh)) - - ptrh2rvapil8 = max(toodry8,ep8 * relhh * rsath / (ep8 + (1.d0-relhh)*rsath)) + !------------------------------------------------------------------------------------! + ! Convert the output to the sought humidity variable. ! + !------------------------------------------------------------------------------------! + if (out_shv) then + !----- Specific humidity. --------------------------------------------------------! + ptrh2rvapil8 = max(toodry8, ep8 * pvap / (pres - (1.d0 - ep8) * pvap)) + !---------------------------------------------------------------------------------! + else + !----- Mixing ratio. -------------------------------------------------------------! + ptrh2rvapil8 = max(toodry8, ep8 * pvap / (pres - pvap)) + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! return end function ptrh2rvapil8 !=======================================================================================! @@ -1190,32 +1882,51 @@ end function ptrh2rvapil8 !=======================================================================================! !=======================================================================================! ! This function computes the relative humidity [fraction] based on pressure, tem- ! - ! perature, and vapour mixing ratio. Two important points: ! + ! perature, and vapour mixing ratio (or specific humidity). Two important points: ! ! 1. IT ALWAYS ASSUME THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE LIQUID PHASE. ! ! If you want to switch between ice and liquid, use rehuil instead. ! ! 2. IT DOESN'T PREVENT SUPERSATURATION TO OCCUR. This is because this subroutine is ! ! also used in the microphysics, where supersaturation does happen and needs to be ! ! accounted. ! !---------------------------------------------------------------------------------------! - real(kind=8) function rehul8(pres,temp,rvpr) - use rconstants, only: ep8,toodry8 + real(kind=8) function rehul8(pres,temp,humi,is_shv) + use rconstants , only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: pres ! Air pressure [ Pa] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rvpr ! Vapour mixing ratio [ kg/kg] + real(kind=8), intent(in) :: pres ! Air pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: humi ! Humidity [ kg/kg] + logical , intent(in) :: is_shv ! Input humidity is specific humidity [ T|F] !----- Local variables --------------------------------------------------------------! - real(kind=8) :: rvprsat ! Saturation mixing ratio [ kg/kg] + real(kind=8) :: shv ! Specific humidity [ kg/kg] + real(kind=8) :: pvap ! Vapour pressure [ Pa] + real(kind=8) :: psat ! Saturation vapour pressure [ Pa] !------------------------------------------------------------------------------------! - rvprsat = max(toodry8,rslf8(pres,temp)) - if (newthermo) then - !----- This is based on relative humidity being defined with vapour pressure -----! - rehul8 = max(0.d0,rvpr*(ep8+rvprsat)/(rvprsat*(ep8+rvpr))) + + !---- Make sure that we have specific humidity. -------------------------------------! + if (is_shv) then + shv = max(toodry8,humi) else - !----- Original formula used by RAMS ---------------------------------------------! - rehul8 = max(0.d0,rvpr/rvprsat) + shv = max(toodry8,humi) / ( 1.d0 + max(toodry8,humi) ) end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the vapour pressure and the saturation vapour pressure. ! + !------------------------------------------------------------------------------------! + pvap = ( pres * shv ) / ( ep8 + (1.d0 - ep8) * shv ) + psat = eslf8(temp) + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Find the relative humidity. ! + !------------------------------------------------------------------------------------! + rehul8 = max(0.d0 , pvap / psat) + !------------------------------------------------------------------------------------! + return end function rehul8 !=======================================================================================! @@ -1229,32 +1940,51 @@ end function rehul8 !=======================================================================================! !=======================================================================================! ! This function computes the relative humidity [fraction] based on pressure, tem- ! - ! perature, and vapour mixing ratio. Two important points: ! + ! perature, and vapour mixing ratio (or specific humidity). Two important points: ! ! 1. IT ALWAYS ASSUME THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE ICE PHASE. ! ! If you want to switch between ice and liquid, use rehuil instead. ! ! 2. IT DOESN'T PREVENT SUPERSATURATION TO OCCUR. This is because this subroutine is ! ! also used in the microphysics, where supersaturation does happen and needs to be ! ! accounted. ! !---------------------------------------------------------------------------------------! - real(kind=8) function rehui8(pres,temp,rvpr) - use rconstants, only: ep8,toodry8 + real(kind=8) function rehui8(pres,temp,humi,is_shv) + use rconstants , only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: pres ! Air pressure [ Pa] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rvpr ! Vapour mixing ratio [ kg/kg] + real(kind=8), intent(in) :: pres ! Air pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: humi ! Humidity [ kg/kg] + logical , intent(in) :: is_shv ! Input humidity is specific humidity [ T|F] !----- Local variables --------------------------------------------------------------! - real(kind=8) :: rvprsat ! Saturation mixing ratio [ kg/kg] + real(kind=8) :: shv ! Specific humidity [ kg/kg] + real(kind=8) :: pvap ! Vapour pressure [ Pa] + real(kind=8) :: psat ! Saturation vapour pressure [ Pa] !------------------------------------------------------------------------------------! - rvprsat = max(toodry8,rsif8(pres,temp)) - if (newthermo) then - !----- This is based on relative humidity being defined with vapour pressure -----! - rehui8 = max(0.d0,rvpr*(ep8+rvprsat)/(rvprsat*(ep8+rvpr))) + + !---- Make sure that we have specific humidity. -------------------------------------! + if (is_shv) then + shv = max(toodry8,humi) else - !----- Original formula used by RAMS ---------------------------------------------! - rehui8 = max(0.d0,rvpr/rvprsat) + shv = max(toodry8,humi) / ( 1.d0 + max(toodry8,humi) ) end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the vapour pressure and the saturation vapour pressure. ! + !------------------------------------------------------------------------------------! + pvap = ( pres * shv ) / ( ep8 + (1.d0 - ep8) * shv ) + psat = esif8(temp) + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Find the relative humidity. ! + !------------------------------------------------------------------------------------! + rehui8 = max(0.d0 , pvap / psat) + !------------------------------------------------------------------------------------! + return end function rehui8 !=======================================================================================! @@ -1268,7 +1998,7 @@ end function rehui8 !=======================================================================================! !=======================================================================================! ! This function computes the relative humidity [fraction] based on pressure, tem- ! - ! perature, and vapour mixing ratio. Two important points: ! + ! perature, and vapour mixing ratio (or specific humidity). Two important points: ! ! 1. It may consider whether the temperature is above or below the freezing point ! ! to choose which saturation to use. It is possible to explicitly force not to use ! ! ice in case level is 2 or if you have reasons not to use ice (e.g. reading data ! @@ -1277,33 +2007,61 @@ end function rehui8 ! also used in the microphysics, where supersaturation does happen and needs to be ! ! accounted. ! !---------------------------------------------------------------------------------------! - real(kind=8) function rehuil8(pres,temp,rvap,useice) - use rconstants, only: t3ple8 + real(kind=8) function rehuil8(pres,temp,humi,is_shv,useice) + use rconstants , only : t3ple8 & ! intent(in) + , ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: pres ! Air pressure [ Pa] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] - logical , intent(in), optional :: useice ! Should I consider ice? [ T|F] + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Air pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: humi ! Humidity [ kg/kg] + logical , intent(in) :: is_shv ! Input is specific humidity [ T|F] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] !----- Local variables --------------------------------------------------------------! - real(kind=8) :: rvapsat ! Saturation mixing ratio [ kg/kg] - logical :: brrr_cold ! I'll use ice sat. now [ T|F] + real(kind=8) :: shv ! Specific humidity [ kg/kg] + real(kind=8) :: pvap ! Vapour pressure [ Pa] + real(kind=8) :: psat ! Saturation vapour pressure [ Pa] + logical :: frozen ! Will use ice saturation now [ T|F] !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! - ! Checking whether I should go with ice or liquid saturation. ! + ! Check whether we should use ice or liquid saturation. ! !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple8 + frozen = useice .and. temp < t3ple8 else - brrr_cold = bulk_on .and. temp < t3ple8 + frozen = bulk_on .and. temp < t3ple8 + end if + !------------------------------------------------------------------------------------! + + + !---- Make sure that we have specific humidity. -------------------------------------! + if (is_shv) then + shv = max(toodry8,humi) + else + shv = max(toodry8,humi) / ( 1.d0 + max(toodry8,humi) ) end if + !------------------------------------------------------------------------------------! - if (brrr_cold) then - rehuil8 = rehui8(pres,temp,rvap) + + !------------------------------------------------------------------------------------! + ! Find the vapour pressure and the saturation vapour pressure. ! + !------------------------------------------------------------------------------------! + pvap = ( pres * shv ) / ( ep8 + (1.d0 - ep8) * shv ) + if (frozen) then + psat = esif8(temp) else - rehuil8 = rehul8(pres,temp,rvap) + psat = esif8(temp) end if + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Find the relative humidity. ! + !------------------------------------------------------------------------------------! + rehuil8 = max(0.d0 ,pvap / psat) + !------------------------------------------------------------------------------------! return end function rehuil8 @@ -1323,23 +2081,33 @@ end function rehuil8 ! 2. This can be used for virtual potential temperature, just give potential tempera- ! ! ture instead of temperature. ! !---------------------------------------------------------------------------------------! - real(kind=8) function tv2temp8(tvir,rvpr,rtot) - use rconstants, only: epi8 + real(kind=8) function tv2temp8(tvir,rvap,rtot) + use rconstants , only : epi8 ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! real(kind=8), intent(in) :: tvir ! Virtual temperature [ K] - real(kind=8), intent(in) :: rvpr ! Vapour mixing ratio [kg/kg] + real(kind=8), intent(in) :: rvap ! Vapour mixing ratio [kg/kg] real(kind=8), intent(in), optional :: rtot ! Total mixing ratio [kg/kg] - !----- Local variable ---------------------------------------------------------------! - real :: rtothere ! Internal rtot [kg/kg] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: rtothere ! Total or vapour mixing ratio [kg/kg] + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Prefer using total mixing ratio, but if it isn't provided, then use vapour ! + ! as total (no condensation). ! + !------------------------------------------------------------------------------------! if (present(rtot)) then rtothere = rtot else - rtothere = rvpr + rtothere = rvap end if + !------------------------------------------------------------------------------------! + - tv2temp8 = tvir * (1.d0 + rtothere) / (1.d0 + epi8*rvpr) + !----- Convert using a generalised function. ----------------------------------------! + tv2temp8 = tvir * (1.d0 + rtothere) / (1.d0 + epi8 * rvap) + !------------------------------------------------------------------------------------! return end function tv2temp8 @@ -1359,23 +2127,33 @@ end function tv2temp8 ! 2. This can be used for virtual potential temperature, just give potential tempera- ! ! ture instead of temperature. ! !---------------------------------------------------------------------------------------! - real(kind=8) function virtt8(temp,rvpr,rtot) - use rconstants, only: epi8 + real(kind=8) function virtt8(temp,rvap,rtot) + use rconstants , only: epi8 ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rvpr ! Vapour mixing ratio [kg/kg] + real(kind=8), intent(in) :: rvap ! Vapour mixing ratio [kg/kg] real(kind=8), intent(in), optional :: rtot ! Total mixing ratio [kg/kg] !----- Local variable ---------------------------------------------------------------! - real :: rtothere ! Internal rtot, to deal with optional [kg/kg] + real(kind=8) :: rtothere ! Total or vapour mixing ratio [kg/kg] + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Prefer using total mixing ratio, but if it isn't provided, then use vapour ! + ! as total (no condensation). ! + !------------------------------------------------------------------------------------! if (present(rtot)) then rtothere = rtot else - rtothere = rvpr + rtothere = rvap end if + !------------------------------------------------------------------------------------! - virtt8 = temp * (1.d0 + epi8 * rvpr) / (1.d0 + rtothere) + + !----- Convert using a generalised function. ----------------------------------------! + virtt8 = temp * (1.d0 + epi8 * rvap) / (1.d0 + rtothere) + !------------------------------------------------------------------------------------! return end function virtt8 @@ -1393,24 +2171,34 @@ end function virtt8 ! gas law. The condensed phase will be taken into account if the user provided both ! ! the vapour and the total mixing ratios. ! !---------------------------------------------------------------------------------------! - real(kind=8) function idealdens8(pres,temp,rvpr,rtot) - use rconstants, only: rdry8 + real(kind=8) function idealdens8(pres,temp,rvap,rtot) + use rconstants , only : rdry8 ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rvpr ! Vapour mixing ratio [kg/kg] - real(kind=8), intent(in), optional :: rtot ! Total mixing ratio [kg/kg] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] + real(kind=8), intent(in), optional :: rtot ! Total mixing ratio [ kg/kg] !----- Local variable ---------------------------------------------------------------! - real(kind=8) :: tvir ! Virtual temperature [ K] + real(kind=8) :: tvir ! Virtual temperature [ K] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Prefer using total mixing ratio, but if it isn't provided, then use vapour ! + ! as total (no condensation). ! !------------------------------------------------------------------------------------! if (present(rtot)) then - tvir = virtt8(temp,rvpr,rtot) + tvir = virtt8(temp,rvap,rtot) else - tvir = virtt8(temp,rvpr) + tvir = virtt8(temp,rvap) end if + !------------------------------------------------------------------------------------! + + !----- Convert using the definition of virtual temperature. -------------------------! idealdens8 = pres / (rdry8 * tvir) + !------------------------------------------------------------------------------------! return end function idealdens8 @@ -1429,25 +2217,34 @@ end function idealdens8 ! provide vapour and total specific mass (specific humidity) instead of mixing ratio. ! !---------------------------------------------------------------------------------------! real(kind=8) function idealdenssh8(pres,temp,qvpr,qtot) - use rconstants, only : rdry8 & ! intent(in) + use rconstants , only : rdry8 & ! intent(in) , epi8 ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: qvpr ! Vapour specific mass [kg/kg] - real(kind=8), intent(in), optional :: qtot ! Total water specific mass [kg/kg] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: qvpr ! Vapour specific mass [ kg/kg] + real(kind=8), intent(in), optional :: qtot ! Total water specific mass [ kg/kg] !----- Local variables. -------------------------------------------------------------! - real(kind=8) :: qall ! Either qtot or qvpr... [kg/kg] + real(kind=8) :: qall ! Either qtot or qvpr... [ kg/kg] !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Prefer using total specific humidity, but if it isn't provided, then use ! + ! vapour phase as the total (no condensation). ! + !------------------------------------------------------------------------------------! if (present(qtot)) then qall = qtot else qall = qvpr end if + !------------------------------------------------------------------------------------! + + !----- Convert using a generalised function. ----------------------------------------! idealdenssh8 = pres / (rdry8 * temp * (1.d0 - qall + epi8 * qvpr)) + !------------------------------------------------------------------------------------! return end function idealdenssh8 @@ -1462,27 +2259,28 @@ end function idealdenssh8 !=======================================================================================! !=======================================================================================! ! This function computes reduces the pressure from the reference height to the ! - ! canopy height by assuming hydrostatic equilibrium. ! + ! canopy height by assuming hydrostatic equilibrium. For simplicity, we assume that ! + ! R and cp are constants (in reality they are dependent on humidity). ! !---------------------------------------------------------------------------------------! real(kind=8) function reducedpress8(pres,thetaref,shvref,zref,thetacan,shvcan,zcan) - use rconstants, only : epim18 & ! intent(in) - , p00k8 & ! intent(in) - , rocp8 & ! intent(in) - , cpor8 & ! intent(in) - , cp8 & ! intent(in) - , grav8 ! ! intent(in) + use rconstants , only : epim18 & ! intent(in) + , p00k8 & ! intent(in) + , rocp8 & ! intent(in) + , cpor8 & ! intent(in) + , cpdry8 & ! intent(in) + , grav8 ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: thetaref ! Potential temperature [ K] - real(kind=8), intent(in) :: shvref ! Vapour specific mass [ kg/kg] - real(kind=8), intent(in) :: zref ! Height at reference level [ m] - real(kind=8), intent(in) :: thetacan ! Potential temperature [ K] - real(kind=8), intent(in) :: shvcan ! Vapour specific mass [ kg/kg] - real(kind=8), intent(in) :: zcan ! Height at canopy level [ m] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: thetaref ! Potential temperature [ K] + real(kind=8), intent(in) :: shvref ! Vapour specific mass [ kg/kg] + real(kind=8), intent(in) :: zref ! Height at reference level [ m] + real(kind=8), intent(in) :: thetacan ! Potential temperature [ K] + real(kind=8), intent(in) :: shvcan ! Vapour specific mass [ kg/kg] + real(kind=8), intent(in) :: zcan ! Height at canopy level [ m] !------Local variables. -------------------------------------------------------------! - real(kind=8) :: pinc ! Pressure increment [ Pa^(R/cp)] - real(kind=8) :: thvbar ! Average virtual pot. temper. [ K] + real(kind=8) :: pinc ! Pressure increment [ Pa^R/cp] + real(kind=8) :: thvbar ! Average virtual pot. temperature [ K] !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! @@ -1490,13 +2288,19 @@ real(kind=8) function reducedpress8(pres,thetaref,shvref,zref,thetacan,shvcan,zc ! top and the reference level. ! !------------------------------------------------------------------------------------! thvbar = 5.d-1 * ( thetaref * (1.d0 + epim18 * shvref) & - + thetacan * (1.d0 + epim18 * shvcan)) + + thetacan * (1.d0 + epim18 * shvcan) ) + !------------------------------------------------------------------------------------! + + !----- Then, we find the pressure gradient scale. -----------------------------------! - pinc = grav8 * p00k8 * (zref - zcan) / (cp8 * thvbar) + pinc = grav8 * p00k8 * (zref - zcan) / (cpdry8 * thvbar) + !------------------------------------------------------------------------------------! + !----- And we can find the reduced pressure. ----------------------------------------! reducedpress8 = (pres**rocp8 + pinc ) ** cpor8 + !------------------------------------------------------------------------------------! return end function reducedpress8 @@ -1508,50 +2312,31 @@ end function reducedpress8 + !=======================================================================================! !=======================================================================================! - ! This function computes the enthalpy given the pressure, temperature, vapour ! - ! specific humidity, and height. Currently it doesn't compute mixed phase air, but ! - ! adding it should be straight forward (finding the inverse is another story...). ! + ! This function computes the Exner function [J/kg/K], given the pressure. It ! + ! assumes for simplicity that R and Cp are constants and equal to the dry air values. ! !---------------------------------------------------------------------------------------! - real(kind=8) function ptqz2enthalpy8(pres,temp,qvpr,zref) - use rconstants, only : ep8 & ! intent(in) - , grav8 & ! intent(in) - , t3ple8 & ! intent(in) - , eta3ple8 & ! intent(in) - , cimcp8 & ! intent(in) - , clmcp8 & ! intent(in) - , cp8 & ! intent(in) - , alvi8 ! ! intent(in) + real(kind=8) function press2exner8(pres) + use rconstants , only : p00i8 & ! intent(in) + , cpdry8 & ! intent(in) + , rocp8 ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: qvpr ! Vapour specific mass [ kg/kg] - real(kind=8), intent(in) :: zref ! Reference height [ m] - !------Local variables. -------------------------------------------------------------! - real(kind=8) :: tequ ! Dew-frost temperature [ K] - real(kind=8) :: pequ ! Equlibrium vapour pressure [ Pa] + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] !------------------------------------------------------------------------------------! - !----- First, we find the equilibrium vapour pressure and dew/frost point. ----------! - pequ = pres * qvpr / (ep8 + (1.d0 - ep8) * qvpr) - tequ = tslif8(pequ) !------------------------------------------------------------------------------------! - ! Then, based on dew/frost point, we compute the enthalpy. This accounts whether ! - ! we would have to dew or frost formation if the temperature dropped to the ! - ! equilibrium point. Notice that if supersaturation exists, this will still give a ! - ! number that makes sense, similar to the internal energy of supercooled water. ! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + press2exner8 = cpdry8 * ( pres * p00i8 ) ** rocp8 !------------------------------------------------------------------------------------! - if (tequ <= t3ple8) then - ptqz2enthalpy8 = cp8 * temp + qvpr * (cimcp8 * tequ + alvi8 ) + grav8 * zref - else - ptqz2enthalpy8 = cp8 * temp + qvpr * (clmcp8 * tequ + eta3ple8) + grav8 * zref - end if return - end function ptqz2enthalpy8 + end function press2exner8 !=======================================================================================! !=======================================================================================! @@ -1560,52 +2345,32 @@ end function ptqz2enthalpy8 + !=======================================================================================! !=======================================================================================! - ! This function computes the temperature given the enthalpy, pressure, vapour ! - ! specific humidity, and reference height. Currently it doesn't compute mixed phase ! - ! air, but adding it wouldn't be horribly hard, though it would require some root ! - ! finding. ! + ! This function computes the pressure [Pa], given the Exner function. Like in the ! + ! function above, we also assume R and Cp to be constants and equal to the dry air ! + ! values. ! !---------------------------------------------------------------------------------------! - real(kind=8) function hpqz2temp8(enthalpy,pres,qvpr,zref) - use rconstants, only : ep8 & ! intent(in) - , grav8 & ! intent(in) - , t3ple8 & ! intent(in) - , eta3ple8 & ! intent(in) - , cimcp8 & ! intent(in) - , clmcp8 & ! intent(in) - , cpi8 & ! intent(in) - , alvi8 ! ! intent(in) + real(kind=8) function exner2press8(exner) + use rconstants , only : p008 & ! intent(in) + , cpdryi8 & ! intent(in) + , cpor8 ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: enthalpy ! Enthalpy... [ J/kg] - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: qvpr ! Vapour specific mass [ kg/kg] - real(kind=8), intent(in) :: zref ! Reference height [ m] - !------Local variables. -------------------------------------------------------------! - real(kind=8) :: tequ ! Dew-frost temperature [ K] - real(kind=8) :: pequ ! Equlibrium vapour pressure [ Pa] + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: exner ! Exner function [ J/kg/K] !------------------------------------------------------------------------------------! - !----- First, we find the equilibrium vapour pressure and dew/frost point. ----------! - pequ = pres * qvpr / (ep8 + (1.d0 - ep8) * qvpr) - tequ = tslif8(pequ) !------------------------------------------------------------------------------------! - ! Then, based on dew/frost point, we compute the temperature. This accounts ! - ! whether we would have to dew or frost formation if the temperature dropped to the ! - ! equilibrium point. Notice that if supersaturation exists, this will still give a ! - ! temperature that makes sense (but less than the dew/frost point), similar to the ! - ! internal energy of supercooled water. ! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + exner2press8 = p008 * ( exner * cpdryi8 ) ** cpor8 !------------------------------------------------------------------------------------! - if (tequ <= t3ple8) then - hpqz2temp8 = cpi8 * (enthalpy - qvpr * (cimcp8 * tequ + alvi8 ) - grav8 * zref) - else - hpqz2temp8 = cpi8 * (enthalpy - qvpr * (clmcp8 * tequ + eta3ple8) - grav8 * zref) - end if return - end function hpqz2temp8 + end function exner2press8 !=======================================================================================! !=======================================================================================! @@ -1614,31 +2379,31 @@ end function hpqz2temp8 + !=======================================================================================! !=======================================================================================! - ! This function finds the temperature given the potential temperature, density, and ! - ! specific humidity. This comes from a combination of the definition of potential ! - ! temperature and the ideal gas law, to eliminate pressure, when pressure is also ! - ! unknown. ! + ! This function computes the potential temperature [K], given the Exner function ! + ! and temperature. For simplicity we ignore the effects of humidity in R and cp and ! + ! use the dry air values instead. ! !---------------------------------------------------------------------------------------! - real(kind=8) function thrhsh2temp8(theta,dens,qvpr) - use rconstants , only : cpocv8 & ! intent(in) - , p00i8 & ! intent(in) - , rdry8 & ! intent(in) - , epim18 & ! intent(in) - , rocv8 ! ! intent(in) + real(kind=8) function extemp2theta8(exner,temp) + use rconstants , only : cpdry8 ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: theta ! Potential temperature [ K] - real(kind=8), intent(in) :: dens ! Density [ Pa] - real(kind=8), intent(in) :: qvpr ! Specific humidity [ kg/kg] + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: exner ! Exner function [ J/kg/K] + real(kind=8), intent(in) :: temp ! Temperature [ K] !------------------------------------------------------------------------------------! - thrhsh2temp8 = theta ** cpocv8 & - * (p00i8 * dens * rdry8 * (1.d0 + epim18 * qvpr)) ** rocv8 + + !------------------------------------------------------------------------------------! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + extemp2theta8 = cpdry8 * temp / exner + !------------------------------------------------------------------------------------! return - end function thrhsh2temp8 + end function extemp2theta8 !=======================================================================================! !=======================================================================================! @@ -1647,48 +2412,32 @@ end function thrhsh2temp8 + !=======================================================================================! !=======================================================================================! - ! This fucntion computes the ice liquid potential temperature given the Exner ! - ! function [J/kg/K], temperature [K], and liquid and ice mixing ratios [kg/kg]. ! + ! This function computes the temperature [K], given the Exner function and ! + ! potential temperature. We simplify the equations by assuming that R and Cp are ! + ! constants. ! !---------------------------------------------------------------------------------------! - real(kind=8) function theta_iceliq8(exner,temp,rliq,rice) - use rconstants, only: alvl8, alvi8, cp8, ttripoli8, htripoli8, htripolii8 + real(kind=8) function extheta2temp8(exner,theta) + use rconstants , only : p00i8 & ! intent(in) + , cpdryi8 ! ! intent(in) implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: exner ! Exner function [J/kg/K] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] - real(kind=8), intent(in) :: rice ! Ice mixing ratio [ kg/kg] - !----- Local variables --------------------------------------------------------------! - real(kind=8) :: hh ! Enthalpy associated with sensible heat [ J/kg] - real(kind=8) :: qq ! Enthalpy associated with latent heat [ J/kg] + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: exner ! Exner function [ J/kg/K] + real(kind=8), intent(in) :: theta ! Potential temperature [ K] !------------------------------------------------------------------------------------! - !----- Finding the enthalpies -------------------------------------------------------! - hh = cp8 * temp - qq = alvl8*rliq + alvi8 * rice - - if (newthermo) then - - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli8) then - theta_iceliq8 = hh * exp(-qq/hh) / exner - else - theta_iceliq8 = hh * exp(-qq * htripolii8) / exner - end if - else - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli8) then - theta_iceliq8 = hh * hh / (exner * ( hh + qq)) - else - theta_iceliq8 = hh * htripoli8 / (exner * ( htripoli8 + qq)) - end if - end if + + !------------------------------------------------------------------------------------! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + extheta2temp8 = cpdryi8 * exner * theta + !------------------------------------------------------------------------------------! return - end function theta_iceliq8 + end function extheta2temp8 !=======================================================================================! !=======================================================================================! @@ -1697,82 +2446,34 @@ end function theta_iceliq8 + !=======================================================================================! !=======================================================================================! - ! This function computes the liquid potential temperature derivative with respect ! - ! to temperature, useful in iterative methods. ! + ! This function computes the specific internal energy of water [J/kg], given the ! + ! temperature and liquid fraction. ! !---------------------------------------------------------------------------------------! - real(kind=8) function dthetail_dt8(condconst,thil,exner,pres,temp,rliq,ricein) - use rconstants, only: alvl8, alvi8, cp8, ttripoli8,htripoli8,htripolii8,t3ple8 - + real(kind=8) function tl2uint8(temp,fliq) + use rconstants , only : cice8 & ! intent(in) + , cliq8 & ! intent(in) + , tsupercool_liq8 ! ! intent(in) + implicit none !----- Arguments --------------------------------------------------------------------! - logical , intent(in) :: condconst ! Condensation is constant? [ T|F] - real(kind=8), intent(in) :: thil ! Ice liquid pot. temp. [ K] - real(kind=8), intent(in) :: exner ! Exner function [J/kg/K] - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] - real(kind=8), intent(in), optional :: ricein ! Ice mixing ratio [ kg/kg] - !----- Local variables --------------------------------------------------------------! - real(kind=8) :: rice ! Ice mixing ratio or 0. [ kg/kg] - real(kind=8) :: ldrst ! L × d(rs)/dT × T [ J/kg] - real(kind=8) :: hh ! Sensible heat enthalpy [ J/kg] - real(kind=8) :: qq ! Latent heat enthalpy [ J/kg] - logical :: thereisice ! Is ice present [ ---] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: fliq ! Fraction liquid water [ kg/kg] !------------------------------------------------------------------------------------! - + + + !------------------------------------------------------------------------------------! - ! Checking whether I should consider ice or not. ! + ! Internal energy is given by the sum of internal energies of ice and liquid ! + ! phases. ! + !------------------------------------------------------------------------------------! + tl2uint8 = (1.d0 - fliq) * cice8 * temp + fliq * cliq8 * (temp - tsupercool_liq8) !------------------------------------------------------------------------------------! - thereisice = present(ricein) - - if (thereisice) then - rice=ricein - else - rice=0.d0 - end if - - !----- No condensation, dthetail_dt is a constant -----------------------------------! - if (rliq+rice == 0.d0) then - dthetail_dt8 = thil/temp - return - else - hh = cp8 * temp !----- Sensible heat enthalpy - qq = alvl8* rliq + alvi8 * rice !----- Latent heat enthalpy - !---------------------------------------------------------------------------------! - ! This is the term L×[d(rs)/dt]×T. L may be either the vapourisation or ! - ! sublimation latent heat, depending on the temperature and whether we are consi- ! - ! dering ice or not. Also, if condensation mixing ratio is constant, then this ! - ! term will be always zero. ! - !---------------------------------------------------------------------------------! - if (condconst) then - ldrst = 0.d0 - elseif (thereisice .and. temp < t3ple8) then - ldrst = alvi8*rsifp8(pres,temp)*temp - else - ldrst = alvl8*rslfp8(pres,temp)*temp - end if - end if - - if (newthermo) then - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli8) then - dthetail_dt8 = thil * (1. + (ldrst + qq)/hh) / temp - else - dthetail_dt8 = thil * (1. + ldrst*htripolii8) / temp - end if - else - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli8) then - dthetail_dt8 = thil * (1.d0 + (ldrst + qq)/(hh+qq)) / temp - else - dthetail_dt8 = thil * (1.d0 + ldrst/(htripoli8 + alvl8*rliq)) / temp - end if - end if return - end function dthetail_dt8 + end function tl2uint8 !=======================================================================================! !=======================================================================================! @@ -1781,239 +2482,93 @@ end function dthetail_dt8 + !=======================================================================================! !=======================================================================================! - ! This function computes temperature from the ice-liquid water potential temperature ! - ! in Kelvin, Exner function in J/kg/K, and liquid and ice mixing ratios in kg/kg. ! - ! For now t1stguess is used only to decide whether I should use the complete case or ! - ! the 253 K to reduce the error on neglecting the changes on latent heat due to temper- ! - ! ature. ! + ! This function computes the internal energy of water [J/m²] or [ J/m³], given the ! + ! temperature [K], the heat capacity of the "dry" part [J/m²/K] or [J/m³/K], water mass ! + ! [ kg/m²] or [ kg/m³], and liquid fraction [---]. ! !---------------------------------------------------------------------------------------! - real(kind=8) function thil2temp8(thil,exner,pres,rliq,rice,t1stguess) - use rconstants, only : cp8 & ! intent(in) - , cpi8 & ! intent(in) - , alvl8 & ! intent(in) - , alvi8 & ! intent(in) - , t008 & ! intent(in) - , t3ple8 & ! intent(in) - , ttripoli8 & ! intent(in) - , htripolii8 & ! intent(in) - , cpi48 ! ! intent(in) + real(kind=8) function cmtl2uext8(dryhcap,wmass,temp,fliq) + use rconstants , only : cice8 & ! intent(in) + , cliq8 & ! intent(in) + , tsupercool_liq8 ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: thil ! Ice-liquid water potential temp. [ K] - real(kind=8), intent(in) :: exner ! Exner function [J/kg/K] - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] - real(kind=8), intent(in) :: rice ! Ice mixing ratio [ kg/kg] - real(kind=8), intent(in) :: t1stguess ! 1st. guess for temperature [ K] - !----- Local variables for iterative method -----------------------------------------! - real(kind=8) :: deriv ! Function derivative - real(kind=8) :: fun ! Function for which we seek a root. - real(kind=8) :: funa ! Smallest guess function - real(kind=8) :: funz ! Largest guess function - real(kind=8) :: tempa ! Smallest guess (or previous guess in Newton) - real(kind=8) :: tempz ! Largest guess (or new guess in Newton) - real(kind=8) :: delta ! Aux. var to compute 2nd guess for bisection - integer :: itn,itb ! Iteration counter - logical :: converged ! Convergence handle - logical :: zside ! Flag to check for one-sided approach... - real(kind=8) :: til ! Ice liquid temperature [ K] + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: dryhcap ! Heat cap. of "dry" part [J/m²/K] or [J/m³/K] + real(kind=8), intent(in) :: wmass ! Mass [ kg/m²] or [ kg/m³] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: fliq ! Liquid fraction (0-1) [ ---] !------------------------------------------------------------------------------------! - !----- 1st. of all, check whether there is condensation. If not, theta_il = theta ---! - if (rliq+rice == 0.d0) then - thil2temp8 = cpi8 * thil * exner - return - !----- If not, check whether we are using the old thermo or the new one -------------! - elseif (.not. newthermo) then - til = cpi8 * thil * exner - if (t1stguess > ttripoli8) then - thil2temp8 = 5.d-1 * (til + sqrt(til * ( til & - + cpi48 * (alvl8*rliq + alvi8*rice)))) - else - thil2temp8 = til * ( 1.d0 + (alvl8*rliq+alvi8*rice) * htripolii8) - end if - return - end if - !------------------------------------------------------------------------------------! - - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,a,1x,f11.4,2(1x,a,1x,es12.5))') & - ! 'itn=',itn,'bisection=',.false.,'tempz=',tempz-t00 & - ! ,'fun=',fun,'deriv=',deriv - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - converged = abs(tempa-tempz) < toler8 * tempz - !----- Converged, happy with that, return the average b/w the 2 previous guesses -! - if (fun == 0.d0) then - thil2temp8 = tempz - converged = .true. - return - elseif(converged) then - thil2temp8 = 5.d-1 * (tempa+tempz) - return - end if - end do newloop - !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! Internal energy is given by the sum of internal energies of dry part, plus the ! + ! contribution of ice and liquid phases. ! + !------------------------------------------------------------------------------------! + cmtl2uext8 = dryhcap * temp + wmass * ( (1.d0 - fliq) * cice8 * temp & + + fliq * cliq8 * (temp - tsupercool_liq8) ) !------------------------------------------------------------------------------------! - if (funa * fun < 0.d0) then - funz = fun - zside = .true. - else - if (abs(fun-funa) < toler8 * tempa) then - delta = 1.d2 * toler8 * tempa - else - delta = max(abs(funa * (tempz-tempa)/(fun-funa)), 1.d2 * toler8 * tempa) - end if - tempz = tempa + delta - zside = .false. - zgssloop: do itb=1,maxfpo - tempz = tempa + dble((-1)**itb * (itb+3)/2) * delta - funz = theta_iceliq8(exner,tempz,rliq,rice) - thil - zside = funa * funz < 0.d0 - if (zside) exit zgssloop - end do zgssloop - if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'thil =',thil ,'t1st=',t1stguess - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'exner=',exner,'pres=',pres - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'rliq =',rliq ,'rice=',rice - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempa=',tempa,'funa=',funa - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempz=',tempz,'funz=',funz - write (unit=*,fmt='(1(a,1x,es14.7,1x))') 'delta=',delta - call abort_run('Failed finding the second guess for regula falsi' & - ,'thil2temp8','therm_lib8.f90') - end if - end if + return + end function cmtl2uext8 + !=======================================================================================! + !=======================================================================================! - bisloop: do itb=itn,maxfpo - thil2temp8 = (funz*tempa-funa*tempz)/(funz-funa) - !---------------------------------------------------------------------------------! - ! Now that we updated the guess, check whether they are really close. If so, ! - ! it converged, I can use this as my guess. ! - !---------------------------------------------------------------------------------! - converged = abs(thil2temp8-tempa) < toler8 * thil2temp8 - if (converged) exit bisloop - !------ Finding the new function -------------------------------------------------! - fun = theta_iceliq8(exner,tempz,rliq,rice) - thil - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,6(1x,a,1x,f11.4))') & - ! 'itn=',itb,'bisection=',.true. & - ! ,'temp=',thil2temp-t00,'tempa=',tempa-t00,'tempz=',tempz-t00 & - ! ,'fun=',fun,'funa=',funa,'funz=',funz - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !------ Defining my new interval based on the intermediate value theorem. --------! - if (fun*funa < 0.d0 ) then - tempz = thil2temp8 - funz = fun - !----- If we are updating zside again, modify aside (Illinois method) ---------! - if (zside) funa=funa * 5.d-1 - !----- We just updated zside, setting zside to true. --------------------------! - zside = .true. - else - tempa = thil2temp8 - funa = fun - !----- If we are updating aside again, modify aside (Illinois method) ---------! - if (.not. zside) funz=funz * 5.d-1 - !----- We just updated aside, setting aside to true. --------------------------! - zside = .false. - end if - end do bisloop - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> ttripoli8) then - dtempdrs8 = - temp * qhydm / (rcon * (hh+qhydm)) - else - dtempdrs8 = - temp * qhydm * htripolii8 / rcon - end if + ! Copy specific humidity to shv. ! + !------------------------------------------------------------------------------------! + if (is_shv) then + shv = humi else - til = cpi8 * thil * exner - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli8) then - dtempdrs8 = - til * qhydm /( rcon * cp8 * (2.d0*temp-til)) - else - dtempdrs8 = - til * qhydm * htripolii8 / rcon - end if + shv = humi / (humi + 1.d0) end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Enthalpy is the combination of dry and moist enthalpies, with the latter being ! + ! allowed to change phase. ! + !------------------------------------------------------------------------------------! + hq2temp8 = ( enthalpy + shv * cph2o8 * tsupercool_vap8 ) & + / ( (1.d0 - shv) * cpdry8 + shv * cph2o8 ) + !------------------------------------------------------------------------------------! return - end function dtempdrs8 + end function hq2temp8 !=======================================================================================! !=======================================================================================! @@ -2084,38 +2632,29 @@ end function dtempdrs8 - !=======================================================================================! !=======================================================================================! - ! This fucntion computes the change of ice-liquid potential temperature due to ! - ! sedimentation. The arguments are ice-liquid potential temperature, potential temper- ! - ! ature and temperature in Kelvin, the old and new mixing ratio [kg/kg] and the old and ! - ! new enthalpy [J/kg]. ! + ! This function finds the latent heat of vaporisation for a given temperature. If ! + ! we use the definition of latent heat (difference in enthalpy between liquid and ! + ! vapour phases), and assume that the specific heats are constants, latent heat becomes ! + ! a linear function of temperature. ! !---------------------------------------------------------------------------------------! - real(kind=8) function dthil_sedimentation8(thil,theta,temp,rold,rnew,qrold,qrnew) - use rconstants, only: ttripoli8,cp8,alvi8,alvl8 - + real(kind=8) function alvl8(temp) + use rconstants , only : alvl38 & ! intent(in) + , dcpvl8 & ! intent(in) + , t3ple8 ! ! intent(in) implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: thil ! Ice-liquid potential temperature [ K] - real(kind=8), intent(in) :: theta ! Potential temperature [ K] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rold ! Old hydrometeor mixing ratio [ kg/kg] - real(kind=8), intent(in) :: rnew ! New hydrometeor mixing ratio [ kg/kg] - real(kind=8), intent(in) :: qrold ! Old hydrometeor latent enthalpy [ J/kg] - real(kind=8), intent(in) :: qrnew ! New hydrometeor latent enthalpy [ J/kg] + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: temp !------------------------------------------------------------------------------------! - if (newthermo) then - dthil_sedimentation8 = - thil * (alvi8 * (rnew-rold) - (qrnew-qrold)) & - / (cp8 * max(temp,ttripoli8)) - else - dthil_sedimentation8 = - thil*thil * (alvi8*(rnew-rold) - (qrnew-qrold)) & - / (cp8 * max(temp,ttripoli8) * theta) - end if + + !----- Linear function, using latent heat at the triple point as reference. ---------! + alvl8 = alvl38 + dcpvl8 * (temp - t3ple8) + !------------------------------------------------------------------------------------! return - end function dthil_sedimentation8 + end function alvl8 !=======================================================================================! !=======================================================================================! @@ -2126,42 +2665,27 @@ end function dthil_sedimentation8 !=======================================================================================! !=======================================================================================! - ! This function computes the ice-vapour equivalent potential temperature from ! - ! theta_iland the total mixing ratio. This is equivalent to the equivalent potential ! - ! temperature considering also the effects of fusion/melting/sublimation. ! - ! In case you want to find thetae (i.e. without ice) simply provide the logical ! - ! useice as .false. . ! + ! This function finds the latent heat of sublimation for a given temperature. If ! + ! we use the definition of latent heat (difference in enthalpy between ice and vapour ! + ! phases), and assume that the specific heats are constants, latent heat becomes a ! + ! linear function of temperature. ! !---------------------------------------------------------------------------------------! - real(kind=8) function thetaeiv8(thil,pres,temp,rvap,rtot,useice) - use rconstants, only : alvl8,alvi8,cp8,ep8,p008,rocp8,ttripoli8,t3ple8 + real(kind=8) function alvi8(temp) + use rconstants , only : alvi38 & ! intent(in) + , dcpvi8 & ! intent(in) + , t3ple8 ! ! intent(in) implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: thil ! Ice-liquid water pot. temp. [ K] - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rvap ! Water vapour mixing ratio [ kg/kg] - real(kind=8), intent(in) :: rtot ! Total mixing ratio [ kg/kg] - logical , intent(in), optional :: useice ! Should I use ice? [ T|F] - !----- Local variables for iterative method -----------------------------------------! - real(kind=8) :: tlcl ! Internal LCL temperature [ K] - real(kind=8) :: plcl ! Lifting condensation pressure [ Pa] - real(kind=8) :: dzlcl ! Thickness of layer beneath LCL[ m] + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: temp !------------------------------------------------------------------------------------! - if (present(useice)) then - call lcl_il8(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl,useice) - else - call lcl_il8(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl) - end if + !----- Linear function, using latent heat at the triple point as reference. ---------! + alvi8 = alvi38 + dcpvi8 * (temp - t3ple8) !------------------------------------------------------------------------------------! - ! The definition of the thetae_iv is the thetae_ivs at the LCL. The LCL, in turn ! - ! is the point in which rtot = rvap = rsat, so at the LCL rliq = rice = 0. ! - !------------------------------------------------------------------------------------! - thetaeiv8 = thetaeivs8(thil,tlcl,rtot,0.d0,0.d0) return - end function thetaeiv8 + end function alvi8 !=======================================================================================! !=======================================================================================! @@ -2172,51 +2696,1277 @@ end function thetaeiv8 !=======================================================================================! !=======================================================================================! - ! This function computes the derivative of ice-vapour equivalent potential tempera- ! - ! ture, based on the expression used to compute the ice-vapour equivalent potential ! - ! temperature (function thetaeiv). ! - ! ! - ! IMPORTANT!!! This CANNOT BE USED to compute d(Thetae_ivs)/dT, because here ! - ! we assume that T(LCL) and saturation mixing ratio are known and ! - ! constants, and that the LCL pressure (actually the saturation vapour ! - ! pressure at the LCL) is a function of temperature. In case you want ! - ! d(Thetae_ivs)/dT, use the dthetaeivs_dt function instead. ! + ! This fucntion computes the ice liquid potential temperature given the Exner ! + ! function [J/kg/K], temperature [K], and liquid and ice mixing ratios [kg/kg]. ! !---------------------------------------------------------------------------------------! - real(kind=8) function dthetaeiv_dtlcl8(theiv,tlcl,rtot,eslcl,useice) - use rconstants, only : rocp8,aklv8,ttripoli8 + real(kind=8) function theta_iceliq8(exner,temp,rliq,rice) + use rconstants , only : alvl38 & ! intent(in) + , alvi38 & ! intent(in) + , cpdry8 & ! intent(in) + , ttripoli8 & ! intent(in) + , htripoli8 & ! intent(in) + , htripolii8 ! ! intent(in) + implicit none !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: theiv ! Ice-vapour equiv. pot. temp. [ K] - real(kind=8), intent(in) :: tlcl ! LCL temperature [ K] - real(kind=8), intent(in) :: rtot ! Total mixing ratio (rs @ LCL)[ Pa] - real(kind=8), intent(in) :: eslcl ! LCL saturation vapour press. [ Pa] - logical , intent(in), optional :: useice ! Flag for considering ice [ T|F] + real(kind=8), intent(in) :: exner ! Exner function [ J/kg/K] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] + real(kind=8), intent(in) :: rice ! Ice mixing ratio [ kg/kg] !----- Local variables --------------------------------------------------------------! - real(kind=8) :: desdtlcl ! Sat. vapour pres. deriv. [ Pa/K] + real(kind=8) :: hh ! Enthalpy associated with sensible heat [ J/kg] + real(kind=8) :: qq ! Enthalpy associated with latent heat [ J/kg] !------------------------------------------------------------------------------------! + !----- Find the sensible heat enthalpy (assuming dry air). --------------------------! + hh = cpdry8 * temp + !------------------------------------------------------------------------------------! - !----- Finding the derivative of rs with temperature --------------------------------! - if (present(useice)) then - desdtlcl = eslifp8(tlcl,useice) + + !------------------------------------------------------------------------------------! + ! Find the latent heat enthalpy. If using the old thermodynamics, we use the ! + ! latent heat at T = T3ple, otherwise we use the temperature-dependent one. ! + !------------------------------------------------------------------------------------! + if (newthermo) then + qq = alvl8(temp) * rliq + alvi8(temp) * rice + else + qq = alvl38 * rliq + alvi38 * rice + end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Solve the thermodynamics. For the new thermodynamics we don't approximate ! + ! the exponential to a linear function, nor do we impose temperature above the thre- ! + ! shold from Tripoli and Cotton (1981). ! + !------------------------------------------------------------------------------------! + if (newthermo) then + !----- Decide how to compute, based on temperature. ------------------------------! + theta_iceliq8 = hh * exp(-qq / hh) / exner + !---------------------------------------------------------------------------------! + else + !----- Decide how to compute, based on temperature. ------------------------------! + if (temp > ttripoli8) then + theta_iceliq8 = hh * hh / (exner * ( hh + qq)) + else + theta_iceliq8 = hh * htripoli8 / (exner * ( htripoli8 + qq)) + end if + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + return + end function theta_iceliq8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the liquid potential temperature derivative with respect ! + ! to temperature, useful in iterative methods. ! + !---------------------------------------------------------------------------------------! + real(kind=8) function dthetail_dt8(condconst,thil,exner,pres,temp,rliq,ricein) + use rconstants , only : alvl38 & ! intent(in) + , alvi38 & ! intent(in) + , dcpvi8 & ! intent(in) + , dcpvl8 & ! intent(in) + , cpdry8 & ! intent(in) + , ttripoli8 & ! intent(in) + , htripoli8 & ! intent(in) + , htripolii8 & ! intent(in) + , t3ple8 ! ! intent(in) + + implicit none + !----- Arguments --------------------------------------------------------------------! + logical , intent(in) :: condconst ! Condensation is constant? [ T|F] + real(kind=8), intent(in) :: thil ! Ice liquid pot. temp. [ K] + real(kind=8), intent(in) :: exner ! Exner function [J/kg/K] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] + real(kind=8), intent(in), optional :: ricein ! Ice mixing ratio [ kg/kg] + !----- Local variables --------------------------------------------------------------! + real(kind=8) :: rice ! Ice mixing ratio or 0. [ kg/kg] + real(kind=8) :: ldrst ! L × d(rs)/dT × T [ J/kg] + real(kind=8) :: rdlt ! r × d(L)/dT × T [ J/kg] + real(kind=8) :: hh ! Sensible heat enthalpy [ J/kg] + real(kind=8) :: qq ! Latent heat enthalpy [ J/kg] + logical :: thereisice ! Is ice present [ ---] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Check whether we should consider ice thermodynamics or not. ! + !------------------------------------------------------------------------------------! + thereisice = present(ricein) + if (thereisice) then + rice = ricein + else + rice = 0.d0 + end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Check whether the current state has condensed water. ! + !------------------------------------------------------------------------------------! + if (rliq+rice == 0.d0) then + !----- No condensation, so dthetail_dt is a constant. ----------------------------! + dthetail_dt8 = thil/temp + return + !---------------------------------------------------------------------------------! + else + !---------------------------------------------------------------------------------! + ! Condensation exists. Compute some auxiliary variables. ! + !---------------------------------------------------------------------------------! + + + !---- Sensible heat enthalpy. ----------------------------------------------------! + hh = cpdry8 * temp + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! Find the latent heat enthalpy. If using the old thermodynamics, we use ! + ! the latent heat at T = T3ple, otherwise we use the temperature-dependent one. ! + ! The term r × d(L)/dT × T is computed only when we use the new thermodynamics. ! + !---------------------------------------------------------------------------------! + if (newthermo) then + qq = alvl8(temp) * rliq + alvi8(temp) * rice + rdlt = (dcpvl8 * rliq + dcpvi8 * rice ) * temp + else + qq = alvl38 * rliq + alvi38 * rice + rdlt = 0.d0 + end if + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! This is the term L×[d(rs)/dt]×T. L may be either the vapourisation or ! + ! sublimation latent heat, depending on the temperature and whether we are consi- ! + ! dering ice or not. We still need to check whether latent heat is a function of ! + ! temperature or not. Also, if condensation mixing ratio is constant, then this ! + ! term will be always zero. ! + !---------------------------------------------------------------------------------! + if (condconst) then + ldrst = 0.d0 + elseif (thereisice .and. temp < t3ple8) then + if (newthermo) then + ldrst = alvi38 * rsifp8(pres,temp) * temp + else + ldrst = alvi8(temp) * rsifp8(pres,temp) * temp + end if + else + if (newthermo) then + ldrst = alvl38 * rslfp8(pres,temp) * temp + else + ldrst = alvl8(temp) * rslfp8(pres,temp) * temp + end if + end if + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Find the condensed phase consistent with the thermodynamics used. ! + !------------------------------------------------------------------------------------! + if (newthermo) then + dthetail_dt8 = thil * ( 1.d0 + (ldrst + qq - rdlt ) / hh ) / temp + else + !----- Decide how to compute, based on temperature. ------------------------------! + if (temp > ttripoli8) then + dthetail_dt8 = thil * ( 1.d0 + (ldrst + qq) / (hh+qq) ) / temp + else + dthetail_dt8 = thil * ( 1.d0 + ldrst / (htripoli8 + alvl38 * rliq) ) / temp + end if + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + return + end function dthetail_dt8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes temperature from the ice-liquid water potential temperature ! + ! in Kelvin, Exner function in J/kg/K, and liquid and ice mixing ratios in kg/kg. ! + ! For now t1stguess is used only to decide whether I should use the complete case or ! + ! the 253 K to reduce the error on neglecting the changes on latent heat due to temper- ! + ! ature. ! + !---------------------------------------------------------------------------------------! + real(kind=8) function thil2temp8(thil,exner,pres,rliq,rice,t1stguess) + use rconstants , only : cpdry8 & ! intent(in) + , cpdryi8 & ! intent(in) + , cpdryi48 & ! intent(in) + , alvl38 & ! intent(in) + , alvi38 & ! intent(in) + , t008 & ! intent(in) + , t3ple8 & ! intent(in) + , ttripoli8 & ! intent(in) + , htripolii8 ! ! intent(in) + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: thil ! Ice-liquid water potential temp. [ K] + real(kind=8), intent(in) :: exner ! Exner function [J/kg/K] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] + real(kind=8), intent(in) :: rice ! Ice mixing ratio [ kg/kg] + real(kind=8), intent(in) :: t1stguess ! 1st. guess for temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: til ! Ice liquid temperature [ K] + real(kind=8) :: deriv ! Function derivative + real(kind=8) :: fun ! Function for which we seek a root. + real(kind=8) :: funa ! Smallest guess function + real(kind=8) :: funz ! Largest guess function + real(kind=8) :: tempa ! Smallest guess (or previous guess in Newton) + real(kind=8) :: tempz ! Largest guess (or new guess in Newton) + real(kind=8) :: delta ! Aux. var to compute 2nd guess for bisection + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + logical :: converged ! Convergence flag + logical :: zside ! Flag to check for one-sided approach... + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! First we check for conditions that don't require iterative root-finding. ! + !------------------------------------------------------------------------------------! + if (rliq + rice == 0.d0) then + !----- No condensation. Theta_il is the same as theta. --------------------------! + thil2temp8 = cpdryi8 * thil * exner + return + !---------------------------------------------------------------------------------! + elseif (.not. newthermo) then + !---------------------------------------------------------------------------------! + ! There is condensation but we are using the old thermodynamics, which can be ! + ! solved analytically. ! + !---------------------------------------------------------------------------------! + til = cpdryi8 * thil * exner + if (t1stguess > ttripoli8) then + thil2temp8 = 5.d-1 & + * (til + sqrt( til & + * (til + cpdryi48 * (alvl38 * rliq + alvi38 * rice)))) + else + thil2temp8 = til * ( 1.d0 + (alvl38 * rliq + alvi38 * rice) * htripolii8) + end if + return + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,a,1x,f11.4,2(1x,a,1x,es12.5))') & + ! 'itn=',itn,'bisection=',.false.,'tempz=',tempz-t00 & + ! ,'fun=',fun,'deriv=',deriv + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + converged = abs(tempa-tempz) < toler8*tempz + !----- Converged, happy with that, return the average b/w the 2 previous guesses -! + if (fun == 0.d0) then + thil2temp8 = tempz + converged = .true. + return + elseif(converged) then + thil2temp8 = 5.d-1 * (tempa+tempz) + return + end if + end do newloop + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! If we have reached this point then Newton's method failed. Use bisection ! + ! instead. For bisection, We need two guesses whose function evaluations have ! + ! opposite sign. ! + !------------------------------------------------------------------------------------! + if (funa * fun < 0.d0) then + !----- Guesses have opposite sign. -----------------------------------------------! + funz = fun + zside = .true. + else + if (abs(fun-funa) < toler8 * tempa) then + delta = 1.d2 * toler8 * tempa + else + delta = max(abs(funa * (tempz-tempa)/(fun-funa)),1.d2 * toler8 * tempa) + end if + tempz = tempa + delta + zside = .false. + zgssloop: do itb=1,maxfpo + tempz = tempa + dble((-1)**itb * (itb+3)/2) * delta + funz = theta_iceliq8(exner,tempz,rliq,rice) - thil + zside = funa*funz < 0.d0 + if (zside) exit zgssloop + end do zgssloop + if (.not. zside) then + write (unit=*,fmt='(a)') ' No second guess for you...' + write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'thil =',thil ,'t1st=',t1stguess + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'exner=',exner,'pres=',pres + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'rliq =',rliq ,'rice=',rice + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempa=',tempa,'funa=',funa + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempz=',tempz,'funz=',funz + write (unit=*,fmt='(1(a,1x,es14.7,1x))') 'delta=',delta + call abort_run ('Failed finding the second guess for regula falsi' & + ,'thil2temp8','therm_lib8.f90') + end if + end if + + + bisloop: do itb=itn,maxfpo + thil2temp8 = (funz*tempa-funa*tempz)/(funz-funa) + + !---------------------------------------------------------------------------------! + ! Now that we updated the guess, check whether they are really close. If so, ! + ! it converged, I can use this as my guess. ! + !---------------------------------------------------------------------------------! + converged = abs(thil2temp8 - tempa) < toler8 * thil2temp8 + if (converged) exit bisloop + + !------ Finding the new function -------------------------------------------------! + fun = theta_iceliq8(exner,tempz,rliq,rice) - thil + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,6(1x,a,1x,f11.4))') & + ! 'itn=',itb,'bisection=',.true. & + ! ,'temp=',thil2temp-t00,'tempa=',tempa-t00,'tempz=',tempz-t00 & + ! ,'fun=',fun,'funa=',funa,'funz=',funz + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + !------ Defining my new interval based on the intermediate value theorem. --------! + if (fun*funa < 0.d0 ) then + tempz = thil2temp8 + funz = fun + !----- If we are updating zside again, modify aside (Illinois method) ---------! + if (zside) funa = funa * 5.d-1 + !----- We just updated zside, setting zside to true. --------------------------! + zside = .true. + else + tempa = thil2temp8 + funa = fun + !----- If we are updating aside again, modify aside (Illinois method) ---------! + if (.not. zside) funz = funz * 5.d-1 + !----- We just updated aside, setting aside to true. --------------------------! + zside = .false. + end if + end do bisloop + + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> ttripoli8) then + dtempdrs8 = - til * qq / ( rcon * cpdry8 * (2.*temp-til)) + else + dtempdrs8 = - til * qq * htripolii8 / rcon + end if + !------------------------------------------------------------------------------! + end if + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + return + end function dtempdrs8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the ice-vapour equivalent potential temperature from ! + ! theta_iland the total mixing ratio. This is equivalent to the equivalent potential ! + ! temperature considering also the effects of fusion/melting/sublimation. ! + ! In case you want to find thetae (i.e. without ice) simply set the the logical ! + ! useice to .false. . ! + !---------------------------------------------------------------------------------------! + real(kind=8) function thetaeiv8(thil,pres,temp,rvap,rtot,useice) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: thil ! Ice-liquid potential temp. [ K] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: rvap ! Water vapour mixing ratio [ kg/kg] + real(kind=8), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! Should I use ice? [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: tlcl ! Internal LCL temperature [ K] + real(kind=8) :: plcl ! Lifting condensation pressure [ Pa] + real(kind=8) :: dzlcl ! Thickness of lyr. beneath LCL [ m] + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Find the liquid condensation level (LCL). ! + !------------------------------------------------------------------------------------! + if (present(useice)) then + call lcl_il8(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl,useice) + else + call lcl_il8(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl) + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! The definition of the thetae_iv is the thetae_ivs at the LCL. The LCL, in turn ! + ! is the point in which rtot = rvap = rsat, so at the LCL rliq = rice = 0. ! + !------------------------------------------------------------------------------------! + thetaeiv8 = thetaeivs8(thil,tlcl,rtot,0.d0,0.d0) + !------------------------------------------------------------------------------------! + + return + end function thetaeiv8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the derivative of ice-vapour equivalent potential tempera- ! + ! ture, based on the expression used to compute the ice-vapour equivalent potential ! + ! temperature (function thetaeiv). ! + ! ! + ! IMPORTANT!!! This CANNOT BE USED to compute d(Thetae_ivs)/dT, because here ! + ! we assume that T(LCL) and saturation mixing ratio are known and ! + ! constants, and that the LCL pressure (actually the saturation vapour ! + ! pressure at the LCL) is a function of temperature. In case you want ! + ! d(Thetae_ivs)/dT, use the dthetaeivs_dt function instead. ! + !---------------------------------------------------------------------------------------! + real(kind=8) function dthetaeiv_dtlcl8(theiv,tlcl,rtot,eslcl,useice) + use rconstants , only : rocp8 & ! intent(in) + , cpdry8 & ! intent(in) + , dcpvl8 ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: theiv ! Ice-vap. equiv. pot. temp. [ K] + real(kind=8), intent(in) :: tlcl ! LCL temperature [ K] + real(kind=8), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + real(kind=8), intent(in) :: eslcl ! LCL sat. vapour pressure [ Pa] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! Flag for considering ice [ T|F] + !----- Local variables --------------------------------------------------------------! + real(kind=8) :: desdtlcl ! Sat. vapour pres. deriv. [ Pa/K] + real(kind=8) :: esterm ! es(TLC) term [ ----] + real(kind=8) :: hhlcl ! Enthalpy -- sensible [ J/kg] + real(kind=8) :: qqlcl ! Enthalpy -- latent [ J/kg] + real(kind=8) :: qptlcl ! Latent deriv. * T_LCL [ J/kg] + !------------------------------------------------------------------------------------! + + + + !----- Find the derivative of rs with temperature. ----------------------------------! + if (present(useice)) then + desdtlcl = eslifp8(tlcl,useice) else desdtlcl = eslifp8(tlcl) end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Saturation term. ! + !------------------------------------------------------------------------------------! + esterm = rocp8 * tlcl * desdtlcl / eslcl + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the enthalpy terms. ! + !------------------------------------------------------------------------------------! + hhlcl = cpdry8 * tlcl + qqlcl = alvl8(tlcl) * rtot + qptlcl = dcpvl8 * rtot * tlcl + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Derivative. ! + !------------------------------------------------------------------------------------! + dthetaeiv_dtlcl8 = theiv / tlcl * (1.d0 - esterm - (qqlcl - qptlcl) / hhlcl) + !------------------------------------------------------------------------------------! + + return + end function dthetaeiv_dtlcl8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the saturation ice-vapour equivalent potential temperature ! + ! from theta_il and the total mixing ratio (split into saturated vapour plus liquid and ! + ! ice. This is equivalent to the equivalent potential temperature considering also the ! + ! effects of fusion/melting/sublimation, and it is done separatedly from the regular ! + ! thetae_iv because it doesn't require iterations. ! + ! ! + ! References: ! + ! Tripoli, J. T.; and Cotton, W.R., 1981: The use of ice-liquid water potential tem- ! + ! perature as a thermodynamic variable in deep atmospheric models. Mon. Wea. ! + ! Rev., v. 109, 1094-1102. (TC81) ! + ! ! + ! Some algebra was needed to find this equation, essentially combining (TC81-26) and ! + ! (TC81-27), and the conservation of total water (TC81-16). It assumes that the divi- ! + ! sion between the three phases is already taken care of. ! + !---------------------------------------------------------------------------------------! + real(kind=8) function thetaeivs8(thil,temp,rsat,rliq,rice) + use rconstants , only : cpdry8 ! ! intent(in) + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: thil ! Theta_il, ice-liquid water pot. temp. [ K] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: rsat ! Saturation water vapour mixing ratio [ kg/kg] + real(kind=8), intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] + real(kind=8), intent(in) :: rice ! Ice mixing ratio [ kg/kg] + !----- Local variables --------------------------------------------------------------! + real(kind=8) :: rtots ! Saturated mixing ratio [ K] + !------------------------------------------------------------------------------------! + + + !------ Find the total saturation mixing ratio. -------------------------------------! + rtots = rsat + rliq + rice + !------------------------------------------------------------------------------------! + + + !------ Find the saturation equivalent potential temperature. -----------------------! + thetaeivs8 = thil * exp ( alvl8(temp) * rtots / (cpdry8 * temp)) + !------------------------------------------------------------------------------------! + + return + end function thetaeivs8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the derivative of saturation ice-vapour equivalent ! + ! potential temperature, based on the expression used to compute the saturation ! + ! ice-vapour equivalent potential temperature (function thetaeivs). ! + ! ! + ! IMPORTANT!!! This CANNOT BE USED to compute d(Thetae_iv)/d(T_LCL), because here ! + ! we assume that temperature and pressure are known and constants, and ! + ! that the mixing ratio is a function of temperature. In case you want ! + ! d(Thetae_iv)/d(T_LCL), use the dthetaeiv_dtlcl function instead. ! + !---------------------------------------------------------------------------------------! + real(kind=8) function dthetaeivs_dt8(theivs,temp,pres,rsat,useice) + use rconstants , only : cpdry8 & ! intent(in) + , dcpvl8 ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: theivs ! Sat. ice-vap. eq. pot. temp. [ K] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! Flag for considering ice [ T|F] + !----- Local variables --------------------------------------------------------------! + real(kind=8) :: drsdt ! Sat. mixing ratio derivative [kg/kg/K] + real(kind=8) :: hh ! Enthalpy -- sensible [ J/kg] + real(kind=8) :: qqaux ! Enthalpy -- sensible [ J/kg] + !------------------------------------------------------------------------------------! + + + !----- Find the derivative of rs with temperature. ----------------------------------! + if (present(useice)) then + drsdt = rslifp8(pres,temp,useice) + else + drsdt = rslifp8(pres,temp) + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Find the enthalpy terms. ! + !------------------------------------------------------------------------------------! + hh = cpdry8 * temp + qqaux = alvl8(temp) * (drsdt * temp - rsat) + dcpvl8 * rsat * temp + !------------------------------------------------------------------------------------! + + + !----- Find the derivative. Depending on the temperature, use different eqn. -------! + dthetaeivs_dt8 = theivs / temp * ( 1.d0 + qqaux / hh ) + !------------------------------------------------------------------------------------! + + return + end function dthetaeivs_dt8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function finds the ice-liquid potential temperature from the ice-vapour equi- ! + ! valent potential temperature. ! + ! Important remarks: ! + ! 1. If you don't want to use ice thermodynamics, simply force useice to be .false. ! + ! Otherwise, the model will decide based on the LEVEL given by the user from their ! + ! RAMSIN. ! + ! 2. If rtot < rsat, then this will convert theta_e into theta, which can be thought as ! + ! a particular case. ! + !---------------------------------------------------------------------------------------! + real(kind=8) function thetaeiv2thil8(theiv,pres,rtot,useice) + use rconstants , only : ep8 & ! intent(in) + , cpdry8 & ! intent(in) + , p008 & ! intent(in) + , rocp8 & ! intent(in) + , t3ple8 & ! intent(in) + , t008 ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: theiv ! Ice vap. equiv. pot. temp. [ K] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May I use ice thermodyn. [ T|F] + !----- Local variables for iterative method -----------------------------------------! + real(kind=8) :: pvap ! Sat. vapour pressure + real(kind=8) :: theta ! Potential temperature + real(kind=8) :: deriv ! Function derivative + real(kind=8) :: funnow ! Function for which we seek a root. + real(kind=8) :: funa ! Smallest guess function + real(kind=8) :: funz ! Largest guess function + real(kind=8) :: tlcla ! Smallest guess (Newton: old guess) + real(kind=8) :: tlclz ! Largest guess (Newton: new guess) + real(kind=8) :: tlcl ! What will be the LCL temperature + real(kind=8) :: es00 ! Defined as p00*rt/(epsilon + rt) + real(kind=8) :: delta ! Aux. variable (For 2nd guess). + integer :: itn ! Iteration counters + integer :: itb ! Iteration counters + integer :: ii ! Another counter + logical :: converged ! Convergence handle + logical :: zside ! Side checker for Regula Falsi + logical :: frozen ! Will use ice thermodynamics + !------------------------------------------------------------------------------------! + + + + !----- Fill the flag for ice thermodynamics so it will be present. ------------------! + if (present(useice)) then + frozen = useice + else + frozen = bulk_on + end if + !------------------------------------------------------------------------------------! + + + + !----- Find es00, which is a constant. ----------------------------------------------! + es00 = p008 * rtot / (ep8 + rtot) + !------------------------------------------------------------------------------------! + + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + ! 'NEWTON: it=',itn,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funnow & + ! ,'deriv=',deriv + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + converged = abs(tlcla-tlclz) < toler8 * tlclz + if (funnow == 0.d0) then + tlcl = tlclz + funz = funnow + converged = .true. + exit newloop + elseif (converged) then + tlcl = 5.d-1*(tlcla+tlclz) + funz = funnow + exit newloop + end if + end do newloop + + !------------------------------------------------------------------------------------! + ! If I reached this point then it's because Newton's method failed. Using bisec- ! + ! tion instead. ! + !------------------------------------------------------------------------------------! + if (.not. converged) then + !----- Set funz, and check whether funa and funz already have opposite sign. -----! + funz = funnow + zside=.true. + if (funa*funnow > 0.d0) then + !----- We fix funa, and try a funz that will work as 2nd guess ----------------! + if (abs(funz-funa) < toler8*tlcla) then + delta = 1.d2*toler8*tlcla + else + delta = max(abs(funa*(tlclz-tlcla)/(funz-funa)),1.d2*toler8*tlcla) + end if + tlclz = tlcla + delta + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + ! '2NGGSS: tt=',itb,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funz & + ! ,'delta=',delta + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + zside = funa*funz < 0.d0 + if (zside) exit zgssloop + end do zgssloop + if (.not. zside) then + write (unit=*,fmt='(a)') ' No second guess for you...' + write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theiv =',theiv ,'rtot =',rtot + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'pres =',pres ,'pvap =',pvap + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theta =',theta ,'delta =',delta + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlcla =',tlcla ,'funa =',funa + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlclz =',tlclz ,'funz =',funz + call abort_run ('Failed finding the second guess for regula falsi' & + ,'thetaeiv2thil8','therm_lib8.f90') + end if + end if + !---- Continue iterative method. -------------------------------------------------! + fpoloop: do itb=itn+1,maxfpo + + !----- Update the guess. ------------------------------------------------------! + tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) + + !----- Updating function evaluation -------------------------------------------! + pvap = eslif8(tlcl,frozen) + theta = tlcl * (es00/pvap)**rocp8 + funnow = thetaeivs8(theta,tlcl,rtot,0.d0,0.d0) - theiv + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=36,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + ! 'ANSWER: itb=',itn,'tlcl=',tlcl-t00,'eslcl=',0.01*pvap & + ! ,'thil=',thetaeiv2thil,'funa=',funa,'funz=',funz + !write (unit=36,fmt='(a)') '-------------------------------------------------------' + !write (unit=36,fmt='(a)') ' ' + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + else + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + write (unit=*,fmt='(a)') ' THEIV2THIL8 failed!' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Input: ' + write (unit=*,fmt='(a,1x,f12.5)') ' THEIV [ K]:',theiv + write (unit=*,fmt='(a,1x,f12.5)') ' PRES [ Pa]:',pres * 1.d2 + write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1.d3*rtot + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Output: ' + write (unit=*,fmt='(a,1x,i12)') ' ITERATIONS :',itb + write (unit=*,fmt='(a,1x,f12.5)') ' PVAP [ hPa]:',pvap + write (unit=*,fmt='(a,1x,f12.5)') ' THETA [ K]:',theta + write (unit=*,fmt='(a,1x,f12.5)') ' TLCL [ °C]:',tlcl-t008 + write (unit=*,fmt='(a,1x,f12.5)') ' TLCLA [ °C]:',tlcla-t008 + write (unit=*,fmt='(a,1x,f12.5)') ' TLCLZ [ °C]:',tlclz-t008 + write (unit=*,fmt='(a,1x,es12.5)') ' FUNA [ K]:',funa + write (unit=*,fmt='(a,1x,es12.5)') ' FUNZ [ K]:',funz + write (unit=*,fmt='(a,1x,es12.5)') ' DERIV [ ---]:',deriv + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_A [ ---]:',abs(tlcl-tlcla)/tlcl + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_Z [ ---]:',abs(tlcl-tlclz)/tlcl + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + + call abort_run ('TLCL didn''t converge, qgave up!' & + ,'thetaeiv2thil8','therm_lib8.f90') + end if + + return + end function thetaeiv2thil8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This subroutine converts saturated ice-vapour equivalent potential temperature ! + ! into temperature, given pressure in Pa, and theta_es in Kelvin. It also returns the ! + ! potential temperature in Kelvin, and saturation vapour mixing ratio in kg/kg. As ! + ! usual, we seek T using Newton's method as a starting point, and if it fails, we fall ! + ! back to the modified regula falsi (Illinois method). ! + ! ! + ! OBS: In case you want to ignore ice, send useice as false. The default is to consider ! + ! when level >= 3 and to ignore otherwise. ! + !---------------------------------------------------------------------------------------! + subroutine thetaeivs2temp8(theivs,pres,theta,temp,rsat,useice) + use rconstants , only : cpdry8 & ! intent(in) + , ep8 & ! intent(in) + , p008 & ! intent(in) + , rocp8 & ! intent(in) + , t008 ! ! intent(in) + implicit none + !----- Arguments --------------------------------------------------------------------! + real(kind=8), intent(in) :: theivs ! Sat. thetae_iv [ K] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(out) :: theta ! Potential temperature [ K] + real(kind=8), intent(out) :: temp ! Temperature [ K] + real(kind=8), intent(out) :: rsat ! Saturation mixing ratio [ kg/kg] + logical , intent(in) , optional :: useice ! May use ice thermodyn. [ T|F] + !----- Local variables, with other thermodynamic properties -------------------------! + real(kind=8) :: exnernormi ! 1./ (Norm. Exner func.) [ ---] + logical :: frozen ! Will use ice thermodyn. [ T|F] + !----- Local variables for iterative method -----------------------------------------! + real(kind=8) :: deriv ! Function derivative + real(kind=8) :: funnow ! Current function evaluation + real(kind=8) :: funa ! Smallest guess function + real(kind=8) :: funz ! Largest guess function + real(kind=8) :: tempa ! Smallest guess (Newton: previous) + real(kind=8) :: tempz ! Largest guess (Newton: new) + real(kind=8) :: delta ! Aux. variable for 2nd guess. + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + logical :: converged ! Convergence handle + logical :: zside ! Flag for side check. + !------------------------------------------------------------------------------------! + + + !----- Set up the ice check, in case useice is not present. -------------------------! + if (present(useice)) then + frozen = useice + else + frozen = bulk_on + end if + !------------------------------------------------------------------------------------! + + + + !----- Finding the inverse of normalised Exner, which is constant in this routine ---! + exnernormi = (p008 /pres) ** rocp8 + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! The 1st. guess, no idea, guess 0°C. ! + !------------------------------------------------------------------------------------! + tempz = t008 + theta = tempz * exnernormi + rsat = rslif8(pres,tempz,frozen) + funnow = thetaeivs8(theta,tempz,rsat,0.d0,0.d0) + deriv = dthetaeivs_dt8(funnow,tempz,pres,rsat,frozen) + funnow = funnow - theivs + !------------------------------------------------------------------------------------! + + + !----- Copy here just in case Newton is aborted at the 1st guess. -------------------! + tempa = tempz + funa = funnow + !------------------------------------------------------------------------------------! + + converged = .false. + !----- Newton's method loop. --------------------------------------------------------! + newloop: do itn=1,maxfpo/6 + if (abs(deriv) < toler8) exit newloop !----- Too dangerous, skip to bisection ----! + !----- Updating guesses ----------------------------------------------------------! + tempa = tempz + funa = funnow + + tempz = tempa - funnow/deriv + theta = tempz * exnernormi + rsat = rslif8(pres,tempz,frozen) + funnow = thetaeivs8(theta,tempz,rsat,0.d0,0.d0) + deriv = dthetaeivs_dt8(funnow,tempz,pres,rsat,frozen) + funnow = funnow - theivs + + converged = abs(tempa-tempz) < toler8*tempz + if (funnow == 0.d0) then + converged =.true. + temp = tempz + exit newloop + elseif (converged) then + temp = 5.d-1*(tempa+tempz) + exit newloop + end if + end do newloop + + !------------------------------------------------------------------------------------! + ! If we have reached this point then it's because Newton's method failed. Use ! + ! bisection instead. ! + !------------------------------------------------------------------------------------! + if (.not. converged) then + !----- Set funz, and check whether funa and funz already have opposite sign. -----! + funz = funnow + zside = .false. + !---------------------------------------------------------------------------------! + + if (funa*funnow > 0.d0) then + !----- We fix funa, and try a funz that will work as 2nd guess ----------------! + if (abs(funz-funa) < toler8*tempa) then + delta = 1.d2*toler8*tempa + else + delta = max(abs(funa*(tempz-tempa)/(funz-funa)),1.d2*toler8*tempa) + end if + !------------------------------------------------------------------------------! + + tempz = tempa + delta + zgssloop: do itb=1,maxfpo + !----- So this will be +1 -1 +2 -2 etc. ------------------------------------! + tempz = tempz + dble((-1)**itb * (itb+3)/2) * delta + theta = tempz * exnernormi + rsat = rslif8(pres,tempz,frozen) + funz = thetaeivs8(theta,tempz,rsat,0.d0,0.d0) - theivs + zside = funa*funz < 0.d0 + if (zside) exit zgssloop + end do zgssloop + if (.not. zside) then + call abort_run ('Failed finding the second guess for regula falsi' & + ,'thetaes2temp8','therm_lib8.f90') + end if + end if + !---- Continue iterative method --------------------------------------------------! + fpoloop: do itb=itn+1,maxfpo + if (abs(funz-funa) < toler8*tempa) then + temp = 5.d-1*(tempa+tempz) + else + temp = (funz*tempa-funa*tempz)/(funz-funa) + end if + theta = temp * exnernormi + rsat = rslif8(pres,temp,frozen) + funnow = thetaeivs8(theta,temp,rsat,0.d0,0.d0) - theivs + + !------------------------------------------------------------------------------! + ! Checking for convergence. If it did, return, we found the solution. ! + ! Otherwise, constrain the guesses. ! + !------------------------------------------------------------------------------! + converged = abs(temp-tempa) < toler8*temp + if (converged) then + exit fpoloop + elseif (funnow*funa < 0.d0) then + tempz = temp + funz = funnow + !----- If we are updating zside again, modify aside (Illinois method) ------! + if (zside) funa=funa * 5.d-1 + !----- We just updated zside, setting zside to true. -----------------------! + zside = .true. + else + tempa = temp + funa = funnow + !----- If we are updating aside again, modify zside (Illinois method) ------! + if (.not. zside) funz = funz * 5.d-1 + !----- We just updated aside, setting zside to false -----------------------! + zside = .false. + end if + end do fpoloop + end if - - - !----- Finding the derivative. Depending on the temperature, use different eqn. -----! - if (tlcl > ttripoli8) then - dthetaeiv_dtlcl8 = theiv * (1.d0 - rocp8*tlcl*desdtlcl/eslcl - aklv8*rtot/tlcl) & - / tlcl + if (converged) then + !----- Compute theta and rsat with temp just for consistency ---------------------! + theta = temp * exnernormi + rsat = rslif8(pres,temp,frozen) else - dthetaeiv_dtlcl8 = theiv * (1.d0 - rocp8*tlcl*desdtlcl/eslcl ) & - / tlcl + call abort_run ('Temperature didn''t converge, I gave up!' & + ,'thetaes2temp8','therm_lib8.f90') end if return - end function dthetaeiv_dtlcl8 + end subroutine thetaeivs2temp8 !=======================================================================================! !=======================================================================================! @@ -2227,353 +3977,348 @@ end function dthetaeiv_dtlcl8 !=======================================================================================! !=======================================================================================! - ! This function computes the saturation ice-vapour equivalent potential temperature ! - ! from theta_il and the total mixing ratio (split into saturated vapour plus liquid and ! - ! ice. This is equivalent to the equivalent potential temperature considering also the ! - ! effects of fusion/melting/sublimation, and it is done separatedly from the regular ! - ! thetae_iv because it doesn't require iterations. ! + ! This subroutine finds the lifting condensation level given the ice-liquid ! + ! potential temperature in Kelvin, temperature in Kelvin, the pressure in Pascal, and ! + ! the mixing ratio in kg/kg. The output will give the LCL temperature and pressure, and ! + ! the thickness of the layer between the initial point and the LCL. ! ! ! ! References: ! - ! Tripoli, J. T.; and Cotton, W.R., 1981: The use of ice-liquid water potential tem- ! - ! perature as a thermodynamic variable in deep atmospheric models. Mon. Wea. ! + ! Tripoli, J. T.; and Cotton, W.R., 1981: The use of ice-liquid water potential ! + ! temperature as a thermodynamic variable in deep atmospheric models. Mon. Wea. ! ! Rev., v. 109, 1094-1102. (TC81) ! + ! Bolton, D., 1980: The computation of the equivalent potential temperature. Mon. ! + ! Wea. Rev., v. 108, 1046-1053. (BO80) ! ! ! ! Some algebra was needed to find this equation, essentially combining (TC81-26) and ! ! (TC81-27), and the conservation of total water (TC81-16). It assumes that the divi- ! ! sion between the three phases is already taken care of. ! + ! Iterative procedure is needed, and here we iterate looking for T(LCL). Theta_il ! + ! can be rewritten in terms of T(LCL) only, and once we know this thetae_iv becomes ! + ! straightforward. T(LCL) will be found using Newton's method, and in the unlikely ! + ! event it fails,we will fall back to the modified regula falsi (Illinois method). ! + ! ! + ! Important remarks: ! + ! 1. TLCL and PLCL are the actual TLCL and PLCL, so in case condensation exists, they ! + ! will be larger than the actual temperature and pressure (because one would go down ! + ! to reach the equilibrium); ! + ! 2. DZLCL WILL BE SET TO ZERO in case the LCL is beneath the starting level. So in ! + ! case you want to force TLCL <= TEMP and PLCL <= PRES, you can use this variable ! + ! to run the saturation check afterwards. DON'T CHANGE PLCL and TLCL here, they will ! + ! be used for conversions between theta_il and thetae_iv as they are defined here. ! + ! 3. In case you don't want ice, simply pass useice=.false.. Otherwise let the model ! + ! decide by itself based on the LEVEL variable. ! !---------------------------------------------------------------------------------------! - real(kind=8) function thetaeivs8(thil,temp,rsat,rliq,rice) - use rconstants, only : aklv8, ttripoli8 + subroutine lcl_il8(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl,useice) + use rconstants , only : cpog8 & ! intent(in) + , ep8 & ! intent(in) + , p008 & ! intent(in) + , rocp8 & ! intent(in) + , t3ple8 & ! intent(in) + , t008 ! ! intent(in) implicit none - !----- Arguments. -------------------------------------------------------------------! - real(kind=8), intent(in) :: thil ! Ice-liquid water potential temp. [ K] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rsat ! Sat. water vapour mixing ratio [ kg/kg] - real(kind=8), intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] - real(kind=8), intent(in) :: rice ! Ice mixing ratio [ kg/kg] + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: thil ! Ice liquid pot. temp. (*)[ K] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + real(kind=8), intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] + real(kind=8), intent(out) :: tlcl ! LCL temperature [ K] + real(kind=8), intent(out) :: plcl ! LCL pressure [ Pa] + real(kind=8), intent(out) :: dzlcl ! Sub-LCL layer thickness [ m] + !------------------------------------------------------------------------------------! + ! (*) This is the most general variable. Thil is exactly theta for no condensation ! + ! condition, and it is the liquid potential temperature if no ice is present. ! + !------------------------------------------------------------------------------------! + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in) , optional :: useice ! May use ice thermodyn.? [ T|F] !----- Local variables. -------------------------------------------------------------! - real(kind=8) :: rtots ! Saturated mixing ratio [ K] + real(kind=8) :: pvap ! Sat. vapour pressure + real(kind=8) :: deriv ! Function derivative + real(kind=8) :: funnow ! Current function evaluation + real(kind=8) :: funa ! Smallest guess function + real(kind=8) :: funz ! Largest guess function + real(kind=8) :: tlcla ! Smallest guess (Newton: previous) + real(kind=8) :: tlclz ! Largest guess (Newton: new) + real(kind=8) :: es00 ! Defined as p00*rt/(epsilon + rt) + real(kind=8) :: delta ! Aux. variable for bisection + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + logical :: converged ! Convergence flag + logical :: zside ! Flag to check sides + logical :: frozen ! Will use ice thermodyn. [ T|F] !------------------------------------------------------------------------------------! - rtots = rsat+rliq+rice - - thetaeivs8 = thil * exp ( aklv8 * rtots / max(temp,ttripoli8)) - - return - end function thetaeivs8 - !=======================================================================================! - !=======================================================================================! - - - - - - !=======================================================================================! - !=======================================================================================! - ! This function computes the derivative of saturation ice-vapour equivalent ! - ! potential temperature, based on the expression used to compute the saturation ! - ! ice-vapour equivalent potential temperature (function thetaeivs). ! - ! ! - ! IMPORTANT!!! This CANNOT BE USED to compute d(Thetae_iv)/d(T_LCL), because here ! - ! we assume that temperature and pressure are known and constants, and ! - ! that the mixing ratio is a function of temperature. In case you want ! - ! d(Thetae_iv)/d(T_LCL), use the dthetaeiv_dtlcl function instead. ! - !---------------------------------------------------------------------------------------! - real(kind=8) function dthetaeivs_dt8(theivs,temp,pres,rsat,useice) - use rconstants, only : aklv8,alvl8,ttripoli8,htripolii8 - implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: theivs ! Sat. ice-vap. eq. pot. temp. [ K] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] - logical , intent(in), optional :: useice ! Flag for considering ice [ T|F] - !----- Local variables --------------------------------------------------------------! - real(kind=8) :: drsdt ! Saturated mixing ratio deriv.[kg/kg/K] !------------------------------------------------------------------------------------! - - - !----- Finding the derivative of rs with temperature --------------------------------! - if (present(useice)) then - drsdt = rslifp8(pres,temp,useice) - else - drsdt = rslifp8(pres,temp) - end if - - - !----- Finding the derivative. Depending on the temperature, use different eqn. -----! - if (temp > ttripoli8) then - dthetaeivs_dt8 = theivs * (1.d0 + aklv8 * (drsdt*temp-rsat)/temp ) / temp - else - dthetaeivs_dt8 = theivs * (1.d0 + alvl8 * drsdt * temp * htripolii8 ) / temp - end if - - - return - end function dthetaeivs_dt8 - !=======================================================================================! - !=======================================================================================! - - - - - - - !=======================================================================================! - !=======================================================================================! - ! This function finds the ice-liquid potential temperature from the ice-vapour equi- ! - ! valent potential temperature. ! - ! Important remarks: ! - ! 1. If you don't want to use ice thermodynamics, simply force useice to be .false. ! - ! Otherwise, the model will decide based on the LEVEL given by the user from their ! - ! RAMSIN. ! - ! 2. If rtot < rsat, then this will convert theta_e into theta, which can be thought as ! - ! a particular case. ! - !---------------------------------------------------------------------------------------! - real(kind=8) function thetaeiv2thil8(theiv,pres,rtot,useice) - use rconstants, only : alvl8,cp8,ep8,p008,rocp8,ttripoli8,t3ple8,t008 - implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: theiv ! Ice vap. equiv. pot. temp. [ K] - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: rtot ! Total mixing ratio [ kg/kg] - logical , intent(in), optional :: useice ! Flag for ice thermo [ T|F] - !----- Local variables for iterative method -----------------------------------------! - real(kind=8) :: pvap ! Sat. vapour pressure - real(kind=8) :: theta ! Potential temperature - real(kind=8) :: deriv ! Function derivative - real(kind=8) :: funnow ! Function for which we seek a root. - real(kind=8) :: funa ! Smallest guess function - real(kind=8) :: funz ! Largest guess function - real(kind=8) :: tlcla ! Smallest guess (or old guess) - real(kind=8) :: tlclz ! Largest guess (or new guess) - real(kind=8) :: tlcl ! What will be the LCL temperature - real(kind=8) :: es00 ! Defined as p00*rt/(epsilon + rt) - real(kind=8) :: delta ! Aux. variable (For 2nd guess). - integer :: itn,itb ! Iteration counters - integer :: ii ! Another counter - logical :: converged ! Convergence handle - logical :: zside ! Aux. flag - sides for Regula Falsi - logical :: brrr_cold ! Flag - considering ice thermo. + ! Check whether ice thermodynamics is the way to go. ! !------------------------------------------------------------------------------------! - - !----- Filling the flag for ice thermo that will be always present ------------------! if (present(useice)) then - brrr_cold = useice - else - brrr_cold = bulk_on + frozen = useice + else + frozen = bulk_on end if - - !----- Finding es00, which is a constant --------------------------------------------! - es00 = p008 * rtot / (ep8 + rtot) - + !------------------------------------------------------------------------------------! !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & ! 'NEWTON: it=',itn,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funnow & ! ,'deriv=',deriv !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - converged = abs(tlcla-tlclz) < toler8 * tlclz - if (funnow == 0.d0) then - tlcl = tlclz + !---------------------------------------------------------------------------------! + ! Check for convergence. ! + !---------------------------------------------------------------------------------! + converged = abs(tlcla-tlclz) < toler8*tlclz + if (converged) then + !----- Guesses are almost identical, average them. ----------------------------! + tlcl = 5.d-1*(tlcla+tlclz) funz = funnow - converged = .true. exit newloop - elseif (converged) then - tlcl = 5.d-1 *(tlcla+tlclz) + !------------------------------------------------------------------------------! + elseif (funnow == 0.d0) then + !----- We've hit the answer by luck, copy the answer. -------------------------! + tlcl = tlclz funz = funnow + converged = .true. exit newloop + !------------------------------------------------------------------------------! end if end do newloop + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! Check whether Newton's method has converged. ! !------------------------------------------------------------------------------------! if (.not. converged) then - !----- Set funz, and check whether funa and funz already have opposite sign. -----! - funz = funnow - zside = .true. - if (funa*funnow > 0.d0) then + !---------------------------------------------------------------------------------! + ! Newton's method has failed. We use regula falsi instead. First, we must ! + ! find two guesses whose function evaluations have opposite signs. ! + !---------------------------------------------------------------------------------! + if (funa*funnow < 0.d0 ) then + !----- We already have two good guesses. --------------------------------------! + funz = funnow + zside = .true. + !------------------------------------------------------------------------------! + else + !------------------------------------------------------------------------------! + ! We need to find another guess with opposite sign. ! + !------------------------------------------------------------------------------! + !----- We fix funa, and try a funz that will work as 2nd guess ----------------! - if (abs(funz-funa) < toler8 * tlcla) then - delta = 1.d2 * toler8 * tlcla + if (abs(funnow-funa) < toler8*tlcla) then + delta = 1.d2*toler8*tlcla else - delta = max(abs(funa*(tlclz-tlcla)/(funz-funa)),1.d2 * toler8 * tlcla) + delta = max(abs(funa*(tlclz-tlcla)/(funnow-funa)),1.d2*toler8*tlcla) end if tlclz = tlcla + delta + !------------------------------------------------------------------------------! !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & ! '2NGGSS: tt=',itb,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funz & ! ,'delta=',delta !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - zside = funa*funz < 0.d0 if (zside) exit zgssloop end do zgssloop if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theiv =',theiv ,'rtot =',rtot - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'pres =',pres ,'pvap =',pvap - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theta =',theta ,'delta =',delta - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlcla =',tlcla ,'funa =',funa - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlclz =',tlclz ,'funz =',funz - call abort_run('Failed finding the second guess for regula falsi' & - ,'thetaeiv2thil8','therm_lib8.f90') + write (unit=*,fmt='(a)') ' ====== No second guess for you... ======' + write (unit=*,fmt='(a)') ' + INPUT variables: ' + write (unit=*,fmt='(a,1x,es14.7)') 'THIL =',thil + write (unit=*,fmt='(a,1x,es14.7)') 'TEMP =',temp + write (unit=*,fmt='(a,1x,es14.7)') 'PRES =',pres + write (unit=*,fmt='(a,1x,es14.7)') 'RTOT =',rtot + write (unit=*,fmt='(a,1x,es14.7)') 'RVAP =',rvap + write (unit=*,fmt='(a)') ' ============ Failed guess... ===========' + write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLA =',tlcla,'FUNA =',funa + write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLZ =',tlclz,'FUNC =',funz + write (unit=*,fmt='(2(a,1x,es14.7))') 'DELTA =',delta,'FUNN =',funnow + call abort_run ('Failed finding the second guess for regula falsi' & + ,'lcl_il8','therm_lib8.f90') end if end if - !---- Continue iterative method --------------------------------------------------! - fpoloop: do itb=itn+1,maxfpo + !---------------------------------------------------------------------------------! - !----- Updating the guess -----------------------------------------------------! - tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) - !----- Updating function evaluation -------------------------------------------! - pvap = eslif8(tlcl,brrr_cold) - theta = tlcl * (es00/pvap)**rocp8 - funnow = thetaeivs8(theta,tlcl,rtot,0.d0,0.d0) - theiv + !---------------------------------------------------------------------------------! + ! We have the guesses, solve the regula falsi method. ! + !---------------------------------------------------------------------------------! + fpoloop: do itb=itn+1,maxfpo + !----- Update guess and function evaluation. ----------------------------------! + tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) + pvap = eslif8(tlcl,frozen) + funnow = tlcl * (es00/pvap)**rocp8 - thil + !------------------------------------------------------------------------------! !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=36,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + !write (unit=21,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),3(a,1x,es11.4,1x))') & ! 'ANSWER: itb=',itn,'tlcl=',tlcl-t00,'eslcl=',0.01*pvap & - ! ,'thil=',thetaeiv2thil,'funa=',funa,'funz=',funz - !write (unit=36,fmt='(a)') '-------------------------------------------------------' - !write (unit=36,fmt='(a)') ' ' + ! ,'dzlcl=',dzlcl,'plcl=',plcl*0.01,'funa=',funa,'funz=',funz + !write (unit=21,fmt='(a)') '-------------------------------------------------------' + !write (unit=21,fmt='(a)') ' ' !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! else - write (unit=*,fmt='(60a1)') ('-',ii=1,60) - write (unit=*,fmt='(a)') ' THEIV2THIL8 failed!' - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' -> Input: ' - write (unit=*,fmt='(a,1x,f12.5)') ' THEIV [ K]:',theiv - write (unit=*,fmt='(a,1x,f12.5)') ' PRES [ Pa]:',pres * 1.d2 - write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1.d3*rtot - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' -> Output: ' - write (unit=*,fmt='(a,1x,i12)') ' ITERATIONS :',itb - write (unit=*,fmt='(a,1x,f12.5)') ' PVAP [ hPa]:',pvap - write (unit=*,fmt='(a,1x,f12.5)') ' THETA [ K]:',theta - write (unit=*,fmt='(a,1x,f12.5)') ' TLCL [ °C]:',tlcl-t008 - write (unit=*,fmt='(a,1x,f12.5)') ' TLCLA [ °C]:',tlcla-t008 - write (unit=*,fmt='(a,1x,f12.5)') ' TLCLZ [ °C]:',tlclz-t008 - write (unit=*,fmt='(a,1x,es12.5)') ' FUNA [ K]:',funa - write (unit=*,fmt='(a,1x,es12.5)') ' FUNZ [ K]:',funz - write (unit=*,fmt='(a,1x,es12.5)') ' DERIV [ ---]:',deriv - write (unit=*,fmt='(a,1x,es12.5)') ' ERR_A [ ---]:',abs(tlcl-tlcla)/tlcl - write (unit=*,fmt='(a,1x,es12.5)') ' ERR_Z [ ---]:',abs(tlcl-tlclz)/tlcl - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(60a1)') ('-',ii=1,60) - - call abort_run('TLCL didn''t converge, gave up!','thetaeiv2thil8' & - ,'therm_lib8.f90') + write (unit=*,fmt='(a)') '-------------------------------------------------------' + write (unit=*,fmt='(a)') ' LCL Temperature didn''t converge!!!' + write (unit=*,fmt='(a,1x,i5,1x,a)') ' I gave up, after',maxfpo,'iterations...' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input values.' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a,1x,f12.4)' ) 'theta_il [ K] =',thil + write (unit=*,fmt='(a,1x,f12.4)' ) 'Pressure [ hPa] =',1.d-2*pres + write (unit=*,fmt='(a,1x,f12.4)' ) 'Temperature [ °C] =',temp-t008 + write (unit=*,fmt='(a,1x,f12.4)' ) 'rtot [ g/kg] =',1.d3*rtot + write (unit=*,fmt='(a,1x,f12.4)' ) 'rvap [ g/kg] =',1.d3*rvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Last iteration outcome.' + write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcla [ °C] =',tlcla-t008 + write (unit=*,fmt='(a,1x,f12.4)' ) 'tlclz [ °C] =',tlclz-t008 + write (unit=*,fmt='(a,1x,f12.4)' ) 'fun [ K] =',funnow + write (unit=*,fmt='(a,1x,f12.4)' ) 'funa [ K] =',funa + write (unit=*,fmt='(a,1x,f12.4)' ) 'funz [ K] =',funz + write (unit=*,fmt='(a,1x,f12.4)' ) 'deriv [ ----] =',deriv + write (unit=*,fmt='(a,1x,es12.4)') 'toler8 [ ----] =',toler8 + write (unit=*,fmt='(a,1x,es12.4)') 'error [ ----] =' & + ,abs(tlclz-tlcla)/tlclz + write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcl [ °C] =',tlcl + call abort_run ('TLCL didn''t converge, gave up!','lcl_il8','therm_lib8.f90') end if - return - end function thetaeiv2thil8 + end subroutine lcl_il8 !=======================================================================================! !=======================================================================================! @@ -2584,167 +4329,409 @@ end function thetaeiv2thil8 !=======================================================================================! !=======================================================================================! - ! This subroutine converts saturated ice-vapour equivalent potential temperature ! - ! into temperature, given pressure in Pa, and theta_es in Kelvin. It also returns the ! - ! potential temperature in Kelvin, and saturation vapour mixing ratio in kg/kg. As ! - ! usual, we seek T using Newton's method as a starting point, and if it fails, we fall ! - ! back to the modified regula falsi (Illinois method). ! - ! ! - ! OBS: In case you want to ignore ice, send useice as false. The default is to consider ! - ! when level >= 3 and to ignore otherwise. ! + ! This subroutine computes a consistent set of temperature and condensated phases ! + ! mixing ratio for a given theta_il, Exner function, and total mixing ratio. This is ! + ! very similar to the function thil2temp, except that now we don't know rliq and rice, ! + ! and for this reason they also become functions of temperature, since they are defined ! + ! as rtot-rsat(T,p), remembering that rtot and p are known. If the air is not ! + ! saturated, we rather use the fact that theta_il = theta and skip the hassle. ! + ! Otherwise, we use iterative methods. We will always try Newton's method, since it ! + ! converges fast. The caveat is that Newton may fail, and it actually does fail very ! + ! close to the triple point, because the saturation vapour pressure function has a ! + ! "kink" at the triple point (continuous, but not differentiable). If that's the case, ! + ! then we fall back to a modified regula falsi (Illinois) method, which is a mix of ! + ! secant and bisection and will converge. ! !---------------------------------------------------------------------------------------! - subroutine thetaeivs2temp8(theivs,pres,theta,temp,rsat,useice) - use rconstants, only : alvl8,cp8,ep8,p008,rocp8,ttripoli8,t008 + subroutine thil2tqall8(thil,exner,pres,rtot,rliq,rice,temp,rvap,rsat) + use rconstants , only : cpdry8 & ! intent(in) + , cpdryi8 & ! intent(in) + , t008 & ! intent(in) + , toodry8 & ! intent(in) + , t3ple8 & ! intent(in) + , ttripoli8 ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: theivs ! Sat. thetae_iv [ K] - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(out) :: theta ! Potential temperature [ K] - real(kind=8), intent(out) :: temp ! Temperature [ K] - real(kind=8), intent(out) :: rsat ! Saturation mixing ratio [ kg/kg] - logical , intent(in) , optional :: useice ! Flag for ice thermo [ T|F] - !----- Local variables, with other thermodynamic properties -------------------------! - real(kind=8) :: exnernormi ! 1./ (Norm. Exner fctn) [ ---] - logical :: brrr_cold ! Flag for ice thermo [ T|F] - !----- Local variables for iterative method -----------------------------------------! - real(kind=8) :: deriv ! Function derivative - real(kind=8) :: funnow ! Function for which we seek a root. - real(kind=8) :: funa ! Smallest guess function - real(kind=8) :: funz ! Largest guess function - real(kind=8) :: tempa ! Smallest guess (or previous) - real(kind=8) :: tempz ! Largest guess (or new) - real(kind=8) :: delta ! Aux. var. for 2nd guess finding. - integer :: itn,itb ! Iteration counters - logical :: converged ! Convergence handle - logical :: zside ! Check sides (Regula Falsi) + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: thil ! Ice-liquid water potential temp. [ K] + real(kind=8), intent(in) :: exner ! Exner function [J/kg/K] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + real(kind=8), intent(out) :: rliq ! Liquid water mixing ratio [ kg/kg] + real(kind=8), intent(out) :: rice ! Ice mixing ratio [ kg/kg] + real(kind=8), intent(inout) :: temp ! Temperature [ K] + real(kind=8), intent(out) :: rvap ! Water vapour mixing ratio [ kg/kg] + real(kind=8), intent(out) :: rsat ! Sat. water vapour mixing ratio [ kg/kg] + !----- Local variables --------------------------------------------------------------! + real(kind=8) :: tempa ! Lower bound for regula falsi iteration + real(kind=8) :: tempz ! Upper bound for regula falsi iteration + real(kind=8) :: t1stguess ! Book keeping temperature 1st guess + real(kind=8) :: fun1st ! Book keeping 1st guess function + real(kind=8) :: funa ! Function evaluation at tempa + real(kind=8) :: funz ! Function evaluation at tempz + real(kind=8) :: funnow ! Function at this iteration. + real(kind=8) :: delta ! Aux. var in case we need regula falsi. + real(kind=8) :: deriv ! Derivative of this function. + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + integer :: ii ! Iteration counter + logical :: converged ! Convergence handle + logical :: zside ! Aux. Flag, for two purposes: + ! 1. Found a 2nd guess for regula falsi. + ! 2. I retained the "zside" (T/F) !------------------------------------------------------------------------------------! - - !----- Setting up the ice check, in case useice is not present. ---------------------! - if (present(useice)) then - brrr_cold = useice - else - brrr_cold = bulk_on + + t1stguess = temp + + !------------------------------------------------------------------------------------! + ! First check: try to find temperature assuming sub-saturation and check if ! + ! this is the case. If it is, then there is no need to go through the iterative ! + ! loop. ! + !------------------------------------------------------------------------------------! + tempz = cpdryi8 * thil * exner + rsat = max(toodry8,rslif8(pres,tempz)) + if (tempz >= t3ple8) then + rliq = max(0.d0,rtot-rsat) + rice = 0.d0 + else + rice = max(0.d0,rtot-rsat) + rliq = 0.d0 end if - - !----- Finding the inverse of normalised Exner, which is constant in this routine ---! - exnernormi = (p008 /pres) ** rocp8 + rvap = rtot-rliq-rice + !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! - ! The 1st. guess, no idea, guess 0°C. ! + ! If rtot < rsat, this is not saturated, we can leave the subroutine and bypass ! + ! the iterative part. ! !------------------------------------------------------------------------------------! - tempz = t008 - theta = tempz * exnernormi - rsat = rslif8(pres,tempz,brrr_cold) - funnow = thetaeivs8(theta,tempz,rsat,0.d0,0.d0) - deriv = dthetaeivs_dt8(funnow,tempz,pres,rsat,brrr_cold) - funnow = funnow - theivs + if (rtot < rsat) then + temp = tempz + return + end if - !----- Saving here just in case Newton is aborted at the 1st guess ------------------! - tempa = tempz - funa = funnow + !------------------------------------------------------------------------------------! + ! If not, then use the temperature the user gave as first guess and solve ! + ! iteratively. We use the user instead of what we just found because if the air is ! + ! saturated, then this can be too far off which may be bad for Newton's method. ! + !------------------------------------------------------------------------------------! + tempz = temp + rsat = max(toodry8,rslif8(pres,tempz)) + if (tempz >= t3ple8) then + rliq = max(0.d0,rtot-rsat) + rice = 0.d0 + else + rice = max(0.d0,rtot-rsat) + rliq = 0.d0 + end if + rvap = rtot-rliq-rice - converged = .false. - !----- Looping ----------------------------------------------------------------------! + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>= t3ple8) then + rliq = max(0.d0,rtot-rsat) + rice = 0.d0 + else + rice = max(0.d0,rtot-rsat) + rliq = 0.d0 + end if + rvap = rtot-rliq-rice + + !----- Updating the function -----------------------------------------------------! + funnow = theta_iceliq8(exner,tempz,rliq,rice) + !----- Updating the derivative. --------------------------------------------------! + deriv = dthetail_dt8(.false.,funnow,exner,pres,tempz,rliq,rice) + funnow = funnow - thil + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=46,fmt='(a,1x,i5,1x,6(a,1x,f11.4,1x),a,1x,es11.4,1x)') & + ! 'NEWTON: it=',itn,'temp=',tempz-t00,'rsat=',1000.*rsat,'rliq=',1000.*rliq & + ! ,'rice=',1000.*rice,'rvap=',1000.*rvap,'fun=',funnow,'deriv=',deriv + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + converged = abs(tempa-tempz) < toler8*tempz + !---------------------------------------------------------------------------------! + ! Convergence. The temperature will be the mid-point between tempa and tempz. ! + ! Fix the mixing ratios and return. But first check for converged due to luck. If ! + ! the guess gives a root, then that's it. It looks unlikely, but it actually ! + ! happens sometimes and if not checked it becomes a singularity. ! + !---------------------------------------------------------------------------------! if (funnow == 0.d0) then - converged =.true. temp = tempz + converged = .true. exit newloop elseif (converged) then temp = 5.d-1 * (tempa+tempz) + rsat = max(toodry8,rslif8(pres,temp)) + if (temp >= t3ple8) then + rliq = max(0.d0,rtot-rsat) + rice = 0.d0 + else + rice = max(0.d0,rtot-rsat) + rliq = 0.d0 + end if + rvap = rtot-rliq-rice exit newloop end if - end do newloop + end do newloop !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! - !------------------------------------------------------------------------------------! + + !----- For debugging only -----------------------------------------------------------! + itb = itn+1 + if (.not. converged) then - !----- Set funz, and check whether funa and funz already have opposite sign. -----! - funz = funnow - zside = .false. - if (funa*funnow > 0.d0) then - !----- We fix funa, and try a funz that will work as 2nd guess ----------------! - if (abs(funz-funa) < toler8 * tempa) then + !---------------------------------------------------------------------------------! + ! If I reach this point, then it means that Newton's method failed finding the ! + ! equilibrium, so we are going to use the regula falsi instead. If Newton's ! + ! method didn't converge, we use tempa as one guess and now we seek a tempz with ! + ! opposite sign. ! + !---------------------------------------------------------------------------------! + !----- Check funa and funnow have opposite signs. If so, we are ready to go ------! + if (funa*funnow < 0.d0) then + funz = funnow + zside = .true. + !----- Otherwise, checking whether the 1st guess had opposite sign. --------------! + elseif (funa*fun1st < 0.d0 ) then + funz = fun1st + zside = .true. + !---------------------------------------------------------------------------------! + ! Looking for a guess. Extrapolate funa linearly, trying to get the -funa. We ! + ! don't need it to be funa, just with the opposite sign. If that's not enough, ! + ! we keep going further... Force the guesses to be at least 1K apart ! + !---------------------------------------------------------------------------------! + else + if (abs(funnow-funa) < 1.d2 * toler8 * tempa) then delta = 1.d2 * toler8 * tempa else - delta = max(abs(funa*(tempz-tempa)/(funz-funa)), 1.d2 * toler8 * tempa) + delta = max(abs(funa)*abs((tempz-tempa)/(funnow-funa)),1.d2*toler8*tempa) end if tempz = tempa + delta + funz = funa + !----- Just to enter at least once. The 1st time tempz=tempa-2*delta ----------! + zside = .false. zgssloop: do itb=1,maxfpo - !----- So this will be +1 -1 +2 -2 etc. ------------------------------------! - tempz = tempz + dble((-1)**itb * (itb+3)/2) * delta - theta = tempz * exnernormi - rsat = rslif8(pres,tempz,brrr_cold) - funz = thetaeivs8(theta,tempz,rsat,0.d0,0.d0) - theivs - zside = funa*funz < 0.d0 - if (zside) exit zgssloop + tempz = tempa + dble((-1)**itb * (itb+3)/2) * delta + rsat = max(toodry8,rslif8(pres,tempz)) + if (tempz >= t3ple8) then + rliq = max(0.d0,rtot-rsat) + rice = 0.d0 + else + rice = max(0.d0,rtot-rsat) + rliq = 0.d0 + end if + rvap = rtot-rliq-rice + funz = theta_iceliq8(exner,tempz,rliq,rice) - thil + zside = funa*funz < 0.d0 + if (zside) exit zgssloop end do zgssloop - if (.not. zside) & - call abort_run('Failed finding the second guess for regula falsi' & - ,'thetaes2temp','therm_lib.f90') + if (.not. zside) then + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + write (unit=*,fmt='(a)') ' THIL2TQALL: NO SECOND GUESS FOR YOU!' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Input: ' + write (unit=*,fmt='(a,1x,f12.5)') ' THETA_IL [ K]:',thil + write (unit=*,fmt='(a,1x,f12.5)') ' PRESS [ hPa]:',1.d-2*pres + write (unit=*,fmt='(a,1x,f12.5)') ' EXNER [J/kg/K]:',exner + write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1.d3*rtot + write (unit=*,fmt='(a,1x,f12.5)') ' T1ST [ degC]:',t1stguess-t008 + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPA [ degC]:',tempa-t008 + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPZ [ degC]:',tempz-t008 + write (unit=*,fmt='(a,1x,f12.5)') ' FUNNOW [ K]:',funnow + write (unit=*,fmt='(a,1x,f12.5)') ' FUNA [ K]:',funa + write (unit=*,fmt='(a,1x,f12.5)') ' FUNZ [ K]:',funz + write (unit=*,fmt='(a,1x,f12.5)') ' DELTA [ K]:',delta + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + + call abort_run ('Failed finding the second guess for regula falsi' & + ,'thil2tqall8','therm_lib8.f90') + end if end if - !---- Continue iterative method --------------------------------------------------! - fpoloop: do itb=itn+1,maxfpo - if (abs(funz-funa) < toler8 * tempa) then - temp = 5.d-1 * (tempa+tempz) + !---------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------! + ! Now we loop until convergence is achieved. One important thing to notice ! + ! is that Newton's method fail only when T is almost T3ple, which means that ice ! + ! and liquid should be present, and we are trying to find the saturation point ! + ! with all ice or all liquid. This will converge but the final answer will ! + ! contain significant error. To reduce it we redistribute the condensates between ! + ! ice and liquid conserving the total condensed mixing ratio. ! + !---------------------------------------------------------------------------------! + fpoloop: do itb=itn,maxfpo + temp = (funz*tempa-funa*tempz)/(funz-funa) + !----- Checking whether this guess will fall outside the range ----------------! + if (abs(temp-tempa) > abs(tempz-tempa) .or. & + abs(temp-tempz) > abs(tempz-tempa)) then + temp = 5.d-1*(tempa+tempz) + end if + !----- Distributing vapour into the three phases ------------------------------! + rsat = max(toodry8,rslif8(pres,temp)) + rvap = min(rtot,rsat) + if (temp >= t3ple8) then + rliq = max(0.d0,rtot-rsat) + rice = 0.d0 else - temp = (funz*tempa-funa*tempz)/(funz-funa) + rliq = 0.d0 + rice = max(0.d0,rtot-rsat) end if - theta = temp * exnernormi - rsat = rslif8(pres,temp,brrr_cold) - funnow = thetaeivs8(theta,temp,rsat,0.d0,0.d0) - theivs + !----- Updating function ------------------------------------------------------! + funnow = theta_iceliq8(exner,temp,rliq,rice) - thil + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> Input: ' + write (unit=*,fmt='(a,1x,f12.5)') ' THETA_IL [ K]:',thil + write (unit=*,fmt='(a,1x,f12.5)') ' EXNER [J/kg/K]:',exner + write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1.d3*rtot + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Output: ' + write (unit=*,fmt='(a,1x,i12)') ' ITERATIONS :',itb + write (unit=*,fmt='(a,1x,f12.5)') ' TEMP [ °C]:',temp-t008 + write (unit=*,fmt='(a,1x,f12.5)') ' RVAP [ g/kg]:',1.d3*rvap + write (unit=*,fmt='(a,1x,f12.5)') ' RLIQ [ g/kg]:',1.d3*rliq + write (unit=*,fmt='(a,1x,f12.5)') ' RICE [ g/kg]:',1.d3*rice + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPA [ °C]:',tempa-t008 + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPZ [ °C]:',tempz-t008 + write (unit=*,fmt='(a,1x,es12.5)') ' FUNA [ K]:',funnow + write (unit=*,fmt='(a,1x,es12.5)') ' FUNZ [ K]:',funnow + write (unit=*,fmt='(a,1x,es12.5)') ' DERIV [ ---]:',deriv + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_A [ ---]:',abs(temp-tempa)/temp + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_Z [ ---]:',abs(temp-tempz)/temp + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + call abort_run ('Failed finding equilibrium, I gave up!','thil2tqall8' & + ,'therm_lib8.f90') end if - + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & - ! 'NEWTON: it=',itn,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funnow & - ! ,'deriv=',deriv - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !----- Go to bisection if the derivative is too flat (too dangerous...) ----------! + if (abs(deriv) < toler8) exit newloop - !------------------------------------------------------------------------------! - ! Convergence may happen when we get close guesses. ! - !------------------------------------------------------------------------------! - converged = abs(tlcla-tlclz) < toler8 * tlclz - if (converged) then - tlcl = 5.d-1*(tlcla+tlclz) - funz = funnow - exit newloop - elseif (funnow == 0.d0) then - tlcl = tlclz - funz = funnow + tempz = tempa - funnow / deriv + + !----- Finding the mixing ratios associated with this guess ----------------------! + rsat = max(toodry8,rslf8(pres,tempz)) + rliq = max(0.d0,rtot-rsat) + rvap = rtot-rliq + + !----- Updating the function -----------------------------------------------------! + funnow = theta_iceliq8(exner,tempz,rliq,0.d0) + !----- Updating the derivative. --------------------------------------------------! + deriv = dthetail_dt8(.false.,funnow,exner,pres,tempz,rliq) + funnow = funnow - thil + + converged = abs(tempa-tempz) < toler8*tempz + !---------------------------------------------------------------------------------! + ! Convergence. The temperature will be the mid-point between tempa and tempz. ! + ! Fix the mixing ratios and return. But first check for converged due to luck. If ! + ! the guess gives a root, then that's it. It looks unlikely, but it actually ! + ! happens sometimes and if not checked it becomes a singularity. ! + !---------------------------------------------------------------------------------! + if (funnow == 0.d0) then + temp = tempz converged = .true. exit newloop + elseif (converged) then + temp = 5.d-1 * (tempa+tempz) + rsat = max(toodry8,rslf8(pres,temp)) + rliq = max(0.d0,rtot-rsat) + rvap = rtot-rliq + exit newloop end if + !---------------------------------------------------------------------------------! end do newloop + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! if (.not. converged) then !---------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using re- ! - ! gula falsi instead. First, I need to find two guesses that give me functions ! - ! with opposite signs. If funa and funnow have opposite signs, then we are all ! - ! set. ! + ! If I reach this point, then it means that Newton's method failed finding the ! + ! equilibrium, so we are going to use the regula falsi instead. If Newton's ! + ! method didn't converge, we use tempa as one guess and now we seek a tempz with ! + ! opposite sign. ! !---------------------------------------------------------------------------------! - if (funa*funnow < 0.d0 ) then - funz = funnow + !----- Check funa and funnow have opposite signs. If so, we are ready to go ------! + if (funa*funnow < 0.d0) then + funz = funnow zside = .true. - !----- They have the same sign, seeking the other guess --------------------------! + !---------------------------------------------------------------------------------! + ! Looking for a guess. Extrapolate funa linearly, trying to get the -funa. We ! + ! don't need it to be funa, just with the opposite sign. If that's not enough, ! + ! we keep going further... Force the guesses to be at least 1K apart ! + !---------------------------------------------------------------------------------! else - - !----- We fix funa, and try a funz that will work as 2nd guess ----------------! - if (abs(funnow-funa) < toler8 * tlcla) then - delta = 1.d2 * toler8 * tlcla + if (abs(funnow-funa) < toler8*tempa) then + delta = 1.d2*toler8*tempa else - delta = max(abs(funa*(tlclz-tlcla)/(funnow-funa)),1.d2 * toler8 * tlcla) + delta = max(abs(funa*(tempz-tempa)/(funnow-funa)),1.d2*toler8*tempa) end if - tlclz = tlcla + delta - - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & - ! '2NGGSS: tt=',itb,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funz & - ! ,'delta=',delta - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + tempz = tempz + dble((-1)**itb * (itb+3)/2) * delta + rsat = max(toodry8,rslf8(pres,tempz)) + rliq = max(0.d0,rtot-rsat) + rvap = rtot-rliq + funz = theta_iceliq8(exner,tempz,rliq,0.d0) - thil zside = funa*funz < 0.d0 if (zside) exit zgssloop end do zgssloop - if (.not. zside) then - write (unit=*,fmt='(a)') ' ====== No second guess for you... ======' - write (unit=*,fmt='(a)') ' + INPUT variables: ' - write (unit=*,fmt='(a,1x,es14.7)') 'THIL =',thil - write (unit=*,fmt='(a,1x,es14.7)') 'TEMP =',temp - write (unit=*,fmt='(a,1x,es14.7)') 'PRES =',pres - write (unit=*,fmt='(a,1x,es14.7)') 'RTOT =',rtot - write (unit=*,fmt='(a,1x,es14.7)') 'RVPR =',rvpr - write (unit=*,fmt='(a)') ' ============ Failed guess... ===========' - write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLA =',tlcla,'FUNA =',funa - write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLZ =',tlclz,'FUNC =',funz - write (unit=*,fmt='(2(a,1x,es14.7))') 'DELTA =',delta,'FUNN =',funnow - call abort_run('Failed finding the second guess for regula falsi' & - ,'lcl_il8','therm_lib8.f90') - end if + if (.not. zside) & + call abort_run ('Failed finding the second guess for regula falsi' & + ,'thil2tqliq','rthrm.f90') end if - !---- Continue iterative method --------------------------------------------------! - fpoloop: do itb=itn+1,maxfpo - - tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) - - pvap = eslif8(tlcl,brrr_cold) - - funnow = tlcl * (es00/pvap)**rocp8 - thil + !---------------------------------------------------------------------------------! - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=21,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),3(a,1x,es11.4,1x))') & - ! 'ANSWER: itb=',itn,'tlcl=',tlcl-t00,'eslcl=',0.01*pvap & - ! ,'dzlcl=',dzlcl,'plcl=',plcl*0.01,'funa=',funa,'funz=',funz - !write (unit=21,fmt='(a)') '-------------------------------------------------------' - !write (unit=21,fmt='(a)') ' ' - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - else - write (unit=*,fmt='(a)') '-------------------------------------------------------' - write (unit=*,fmt='(a)') ' LCL Temperature didn''t converge!!!' - write (unit=*,fmt='(a,1x,i5,1x,a)') ' I gave up, after',maxfpo,'iterations...' - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' Input values.' - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a,1x,f12.4)' ) 'theta_il [ K] =',thil - write (unit=*,fmt='(a,1x,f12.4)' ) 'Pressure [ hPa] =',1.d-2*pres - write (unit=*,fmt='(a,1x,f12.4)' ) 'Temperature [ °C] =',temp-t008 - write (unit=*,fmt='(a,1x,f12.4)' ) 'rtot [ g/kg] =',1.d3*rtot - write (unit=*,fmt='(a,1x,f12.4)' ) 'rvpr [ g/kg] =',10.d3*rvpr - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' Last iteration outcome.' - write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcla [ °C] =',tlcla-t008 - write (unit=*,fmt='(a,1x,f12.4)' ) 'tlclz [ °C] =',tlclz-t008 - write (unit=*,fmt='(a,1x,f12.4)' ) 'fun [ K] =',funnow - write (unit=*,fmt='(a,1x,f12.4)' ) 'funa [ K] =',funa - write (unit=*,fmt='(a,1x,f12.4)' ) 'funz [ K] =',funz - write (unit=*,fmt='(a,1x,f12.4)' ) 'deriv [ ----] =',deriv - write (unit=*,fmt='(a,1x,es12.4)') 'toler [ ----] =',toler8 - write (unit=*,fmt='(a,1x,es12.4)') 'error [ ----] =' & - ,abs(tlclz-tlcla)/tlclz - write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcl [ °C] =',tlcl - call abort_run('TLCL didn''t converge, gave up!','lcl_il8','therm_lib8.f90') - end if + + if (.not. converged) call abort_run ('Failed finding equilibrium, I gave up!' & + ,'thil2tqliq8','therm_lib8.f90') return - end subroutine lcl_il8 + end subroutine thil2tqliq8 !=======================================================================================! !=======================================================================================! @@ -3056,35 +4987,48 @@ end subroutine lcl_il8 !=======================================================================================! !=======================================================================================! ! This subroutine computes the temperature and fraction of liquid water from the ! - ! internal energy . This requires double precision arguments. ! + ! intensive internal energy [J/kg]. ! !---------------------------------------------------------------------------------------! - subroutine qtk8(q,tempk,fracliq) - use rconstants, only: cliqi8,cicei8,allii8,t3ple8,qicet38,qliqt38,tsupercool8 + subroutine uint2tl8(uint,temp,fliq) + use rconstants , only : cliqi8 & ! intent(in) + , cicei8 & ! intent(in) + , allii8 & ! intent(in) + , t3ple8 & ! intent(in) + , uiicet38 & ! intent(in) + , uiliqt38 & ! intent(in) + , tsupercool_liq8 ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: q ! Internal energy [ J/kg] - real(kind=8), intent(out) :: tempk ! Temperature [ K] - real(kind=8), intent(out) :: fracliq ! Liquid Fraction (0-1) [ ---] + real(kind=8), intent(in) :: uint ! Internal energy [ J/kg] + real(kind=8), intent(out) :: temp ! Temperature [ K] + real(kind=8), intent(out) :: fliq ! Liquid Fraction (0-1) [ ---] !------------------------------------------------------------------------------------! - !----- Internal energy below qwfroz, all ice ---------------------------------------! - if (q <= qicet38) then - fracliq = 0.d0 - tempk = q * cicei8 - !----- Internal energy, above qwmelt, all liquid ------------------------------------! - elseif (q >= qliqt38) then - fracliq = 1.d0 - tempk = q * cliqi8 + tsupercool8 - !----- Changing phase, it must be at freezing point ---------------------------------! + !------------------------------------------------------------------------------------! + ! Compare the internal energy with the reference values to decide which phase ! + ! the water is. ! + !------------------------------------------------------------------------------------! + if (uint <= uiicet38) then + !----- Internal energy below qwfroz, all ice ------------------------------------! + fliq = 0.d0 + temp = uint * cicei8 + !---------------------------------------------------------------------------------! + elseif (uint >= uiliqt38) then + !----- Internal energy, above qwmelt, all liquid ---------------------------------! + fliq = 1.d0 + temp = uint * cliqi8 + tsupercool_liq8 + !---------------------------------------------------------------------------------! else - fracliq = (q-qicet38) * allii8 - tempk = t3ple8 - endif + !----- Changing phase, it must be at freezing point ------------------------------! + fliq = (uint - uiicet38) * allii8 + temp = t3ple8 + !---------------------------------------------------------------------------------! + end if !------------------------------------------------------------------------------------! return - end subroutine qtk8 + end subroutine uint2tl8 !=======================================================================================! !=======================================================================================! @@ -3095,66 +5039,81 @@ end subroutine qtk8 !=======================================================================================! !=======================================================================================! - ! This subroutine computes the temperature (Kelvin) and liquid fraction from inter- ! - ! nal energy (J/m² or J/m³), mass (kg/m² or kg/m³), and heat capacity (J/m²/K or ! - ! J/m³/K). ! - ! This routine requires an 8-byte double precision floating point value for density. ! + ! This subroutine computes the temperature (Kelvin) and liquid fraction from ! + ! extensive internal energy (J/m² or J/m³), water mass (kg/m² or kg/m³), and heat ! + ! capacity (J/m²/K or J/m³/K). ! !---------------------------------------------------------------------------------------! - subroutine qwtk8(qw,w,dryhcap,tempk,fracliq) - use rconstants, only: cliqi8,cliq8,cicei8,cice8,allii8,alli8,t3ple8,tsupercool8 + subroutine uextcm2tl8(uext,wmass,dryhcap,temp,fliq) + use rconstants , only : cliqi8 & ! intent(in) + , cliq8 & ! intent(in) + , cicei8 & ! intent(in) + , cice8 & ! intent(in) + , allii8 & ! intent(in) + , alli8 & ! intent(in) + , t3ple8 & ! intent(in) + , tsupercool_liq8 ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: qw ! Internal energy [ J/m²] or [ J/m³] - real(kind=8), intent(in) :: w ! Density [ kg/m²] or [ kg/m³] - real(kind=8), intent(in) :: dryhcap ! Heat capacity, nonwater [J/m²/K] or [J/m³/K] - real(kind=8), intent(out) :: tempk ! Temperature [ K] - real(kind=8), intent(out) :: fracliq ! Liquid fraction (0-1) [ ---] + real(kind=8), intent(in) :: uext ! Extensive internal energy [ J/m²] or [ J/m³] + real(kind=8), intent(in) :: wmass ! Water mass [ kg/m²] or [ kg/m³] + real(kind=8), intent(in) :: dryhcap ! Heat cap. of "dry" part [J/m²/K] or [J/m³/K] + real(kind=8), intent(out) :: temp ! Temperature [ K] + real(kind=8), intent(out) :: fliq ! Liquid fraction (0-1) [ ---] !----- Local variable ---------------------------------------------------------------! - real(kind=8) :: qwfroz ! qw of ice at triple pt. [ J/m²] or [ J/m³] - real(kind=8) :: qwmelt ! qw of liquid at triple pt.[ J/m²] or [ J/m³] + real(kind=8) :: uefroz ! qw of ice at triple pt. [ J/m²] or [ J/m³] + real(kind=8) :: uemelt ! qw of liq. at triple pt. [ J/m²] or [ J/m³] !------------------------------------------------------------------------------------! - !----- Converting melting heat to J/m² or J/m³ --------------------------------------! - qwfroz = (dryhcap + w*cice8) * t3ple8 - qwmelt = qwfroz + w*alli8 - !------------------------------------------------------------------------------------! - - !------------------------------------------------------------------------------------! - ! This is analogous to the qtk computation, we should analyse the magnitude of ! - ! the internal energy to choose between liquid, ice, or both by comparing with our. ! - ! know boundaries. ! - !------------------------------------------------------------------------------------! - !----- Internal energy below qwfroz, all ice ---------------------------------------! - if (qw < qwfroz) then - fracliq = 0.d0 - tempk = qw / (cice8 * w + dryhcap) - !----- Internal energy, above qwmelt, all liquid ------------------------------------! - elseif (qw > qwmelt) then - fracliq = 1.d0 - tempk = (qw + w * cliq8 * tsupercool8) / (dryhcap + w*cliq8) - !------------------------------------------------------------------------------------! - ! We are at the freezing point. If water mass is so tiny that the internal ! - ! energy of frozen and melted states are the same given the machine precision, then ! - ! we assume that water content is negligible and we impose 50% frozen for ! - ! simplicity. ! + + !----- Convert melting heat to J/m² or J/m³ -----------------------------------------! + uefroz = (dryhcap + wmass * cice8) * t3ple8 + uemelt = uefroz + wmass * alli8 !------------------------------------------------------------------------------------! - elseif (qwfroz == qwmelt) then - fracliq = 5.d-1 - tempk = t3ple8 + + + !------------------------------------------------------------------------------------! - ! Changing phase, it must be at freezing point. The max and min are here just to ! - ! avoid tiny deviations beyond 0. and 1. due to floating point arithmetics. ! + ! This is analogous to the uint2tl8 computation, we should analyse the magnitude ! + ! of the internal energy to choose between liquid, ice, or both by comparing with ! + ! the known boundaries. ! !------------------------------------------------------------------------------------! + if (uext < uefroz) then + !----- Internal energy below qwfroz, all ice ------------------------------------! + fliq = 0.d0 + temp = uext / (cice8 * wmass + dryhcap) + !---------------------------------------------------------------------------------! + elseif (uext > uemelt) then + !----- Internal energy, above qwmelt, all liquid ---------------------------------! + fliq = 1.d0 + temp = (uext + wmass * cliq8 * tsupercool_liq8) / (dryhcap + wmass * cliq8) + !---------------------------------------------------------------------------------! + elseif (uefroz == uemelt) then + !---------------------------------------------------------------------------------! + ! We are at the freezing point. If water mass is so tiny that the internal ! + ! energy of frozen and melted states are the same given the machine precision, ! + ! then we assume that water content is negligible and we impose 50% frozen for ! + ! simplicity. ! + !---------------------------------------------------------------------------------! + fliq = 5.d-1 + temp = t3ple8 + !---------------------------------------------------------------------------------! else - fracliq = min(1.d0,max(0.d0,(qw - qwfroz) * allii8 / w)) - tempk = t3ple8 + !---------------------------------------------------------------------------------! + ! Changing phase, it must be at freezing point. The max and min are here just ! + ! to avoid tiny deviations beyond 0. and 1. due to floating point arithmetics. ! + !---------------------------------------------------------------------------------! + fliq = min(1.d0,max(0.d0,(uext - uefroz) * allii8 / wmass)) + temp = t3ple8 + !---------------------------------------------------------------------------------! end if !------------------------------------------------------------------------------------! return - end subroutine qwtk8 + end subroutine uextcm2tl8 !=======================================================================================! !=======================================================================================! end module therm_lib8 +!==========================================================================================! +!==========================================================================================! diff --git a/BRAMS/src/mass/mem_mass.f90 b/BRAMS/src/mass/mem_mass.f90 index 3bd6cb650..41f99d21c 100644 --- a/BRAMS/src/mass/mem_mass.f90 +++ b/BRAMS/src/mass/mem_mass.f90 @@ -195,25 +195,25 @@ subroutine nullify_mass(mass) implicit none type (mass_vars) :: mass - if (associated(mass%thvlast )) nullify (mass%thvlast ) - if (associated(mass%lnthetav )) nullify (mass%lnthetav ) - if (associated(mass%lnthvadv )) nullify (mass%lnthvadv ) - if (associated(mass%lnthvtend )) nullify (mass%lnthvtend ) - if (associated(mass%afxu )) nullify (mass%afxu ) - if (associated(mass%afxv )) nullify (mass%afxv ) - if (associated(mass%afxw )) nullify (mass%afxw ) - if (associated(mass%ltscaleb )) nullify (mass%ltscaleb ) - if (associated(mass%sigwb )) nullify (mass%sigwb ) - if (associated(mass%tkepb )) nullify (mass%tkepb ) - if (associated(mass%afxub )) nullify (mass%afxub ) - if (associated(mass%afxvb )) nullify (mass%afxvb ) - if (associated(mass%afxwb )) nullify (mass%afxwb ) - if (associated(mass%cfxup )) nullify (mass%cfxup ) - if (associated(mass%cfxdn )) nullify (mass%cfxdn ) - if (associated(mass%dfxup )) nullify (mass%dfxup ) - if (associated(mass%efxup )) nullify (mass%efxup ) - if (associated(mass%dfxdn )) nullify (mass%dfxdn ) - if (associated(mass%efxdn )) nullify (mass%efxdn ) + nullify (mass%thvlast ) + nullify (mass%lnthetav ) + nullify (mass%lnthvadv ) + nullify (mass%lnthvtend ) + nullify (mass%afxu ) + nullify (mass%afxv ) + nullify (mass%afxw ) + nullify (mass%ltscaleb ) + nullify (mass%sigwb ) + nullify (mass%tkepb ) + nullify (mass%afxub ) + nullify (mass%afxvb ) + nullify (mass%afxwb ) + nullify (mass%cfxup ) + nullify (mass%cfxdn ) + nullify (mass%dfxup ) + nullify (mass%efxup ) + nullify (mass%dfxdn ) + nullify (mass%efxdn ) return end subroutine nullify_mass !==========================================================================================! diff --git a/BRAMS/src/mass/rexev.f90 b/BRAMS/src/mass/rexev.f90 index 567770b6a..fa255d9f6 100644 --- a/BRAMS/src/mass/rexev.f90 +++ b/BRAMS/src/mass/rexev.f90 @@ -51,7 +51,8 @@ subroutine exevolve(m1,m2,m3,ifm,ia,iz,ja,jz,izu,jzv,jdim,mynum,edt,key) ! not a "dry" run. Otherwise, leave the values equal to zero, which will impose ! ! theta=theta_v ! !---------------------------------------------------------------------------------------! - call azero2(m1*m2*m3,scratch%vt3dp,scratch%vt3dq) + call azero(m1*m2*m3,scratch%vt3dp) + call azero(m1*m2*m3,scratch%vt3dq) if (vapour_on) then !----- If water is allowed, copy them to scratch arrays -----------------------------! call atob(m1*m2*m3,basic_g(ifm)%rtp,scratch%vt3dp) @@ -484,7 +485,9 @@ subroutine exthvadv(m1,m2,m3,ia,iz,ja,jz,izu,jzv,jdim,mynum,edt,up,uc,vp,vc,wp,w !----- Save the total size of matrices -------------------------------------------------! isiz=m1*m2*m3 - call azero3(m1*m2*m3,scratch%vt3da,scratch%vt3db,scratch%vt3dc) + call azero(m1*m2*m3,scratch%vt3da) + call azero(m1*m2*m3,scratch%vt3db) + call azero(m1*m2*m3,scratch%vt3dc) call prep_timeave(m1,m2,m3,edt,up,uc,vp,vc,wp,wc,scratch%vt3da,scratch%vt3db & ,scratch%vt3dc) diff --git a/BRAMS/src/memory/dealloc.f90 b/BRAMS/src/memory/dealloc.f90 index 014e10f94..aefd31053 100644 --- a/BRAMS/src/memory/dealloc.f90 +++ b/BRAMS/src/memory/dealloc.f90 @@ -46,7 +46,7 @@ subroutine dealloc_all() use mem_mass, only : mass_g, massm_g, dealloc_mass use mem_scratch1_grell, only : sc1_grell_g,dealloc_scratch1_grell use mem_tend, only : tend_g, dealloc_tend - + use mem_mnt_advec, only : iadvec, advec_g, advecm_g, dealloc_advec implicit none ! deallocate all model memory. Used on dynamic balance @@ -92,6 +92,9 @@ subroutine dealloc_all() call dealloc_varinit(varinit_g(ng)) call dealloc_varinit(varinitm_g(ng)) + call dealloc_advec(advec_g(ng)) + call dealloc_advec(advecm_g(ng)) + call dealloc_mass(mass_g(ng)) call dealloc_mass(massm_g(ng)) @@ -115,17 +118,18 @@ subroutine dealloc_all() endif enddo - if (allocated(tend_g )) deallocate(tend_g ) - if (allocated(basic_g )) deallocate(basic_g ,basicm_g ) - if (allocated(cuparm_g )) deallocate(cuparm_g ,cuparmm_g ) - if (allocated(grid_g )) deallocate(grid_g ,gridm_g ) - if (allocated(leaf_g )) deallocate(leaf_g ,leafm_g ) - if (allocated(micro_g )) deallocate(micro_g ,microm_g ) - if (allocated(radiate_g)) deallocate(radiate_g ,radiatem_g ) - if (allocated(turb_g )) deallocate(turb_g ,turbm_g ) - if (allocated(varinit_g)) deallocate(varinit_g ,varinitm_g ) - if (allocated(oda_g )) deallocate(oda_g ,odam_g ) - if (allocated(mass_g )) deallocate(mass_g ,massm_g ) + if (allocated(tend_g )) deallocate(tend_g ) + if (allocated(basic_g )) deallocate(basic_g ,basicm_g ) + if (allocated(cuparm_g )) deallocate(cuparm_g ,cuparmm_g ) + if (allocated(grid_g )) deallocate(grid_g ,gridm_g ) + if (allocated(leaf_g )) deallocate(leaf_g ,leafm_g ) + if (allocated(micro_g )) deallocate(micro_g ,microm_g ) + if (allocated(radiate_g )) deallocate(radiate_g ,radiatem_g ) + if (allocated(turb_g )) deallocate(turb_g ,turbm_g ) + if (allocated(varinit_g )) deallocate(varinit_g ,varinitm_g ) + if (allocated(oda_g )) deallocate(oda_g ,odam_g ) + if (allocated(mass_g )) deallocate(mass_g ,massm_g ) + if (allocated(advec_g )) deallocate(advec_g ,advecm_g ) if (allocated(sc1_grell_g)) deallocate(sc1_grell_g) if (TEB_SPM==1) then diff --git a/BRAMS/src/memory/mem_basic.f90 b/BRAMS/src/memory/mem_basic.f90 index 4976cf77b..32b6baf42 100644 --- a/BRAMS/src/memory/mem_basic.f90 +++ b/BRAMS/src/memory/mem_basic.f90 @@ -117,27 +117,28 @@ subroutine nullify_basic(basic) type (basic_vars) :: basic !------------------------------------------------------------------------------------! - if (associated(basic%up )) nullify (basic%up ) - if (associated(basic%uc )) nullify (basic%uc ) - if (associated(basic%vp )) nullify (basic%vp ) - if (associated(basic%vc )) nullify (basic%vc ) - if (associated(basic%wp )) nullify (basic%wp ) - if (associated(basic%wc )) nullify (basic%wc ) - if (associated(basic%pp )) nullify (basic%pp ) - if (associated(basic%pc )) nullify (basic%pc ) - if (associated(basic%thp )) nullify (basic%thp ) - if (associated(basic%rtp )) nullify (basic%rtp ) - if (associated(basic%co2p )) nullify (basic%co2p ) - if (associated(basic%rv )) nullify (basic%rv ) - if (associated(basic%theta )) nullify (basic%theta ) - if (associated(basic%pi0 )) nullify (basic%pi0 ) - if (associated(basic%th0 )) nullify (basic%th0 ) - if (associated(basic%dn0 )) nullify (basic%dn0 ) - if (associated(basic%dn0u )) nullify (basic%dn0u ) - if (associated(basic%dn0v )) nullify (basic%dn0v ) - if (associated(basic%fcoru )) nullify (basic%fcoru ) - if (associated(basic%fcorv )) nullify (basic%fcorv ) - if (associated(basic%cputime )) nullify (basic%cputime ) + nullify (basic%up ) + nullify (basic%uc ) + nullify (basic%vp ) + nullify (basic%vc ) + nullify (basic%wp ) + nullify (basic%wc ) + nullify (basic%pp ) + nullify (basic%pc ) + nullify (basic%thp ) + nullify (basic%rtp ) + nullify (basic%co2p ) + nullify (basic%rv ) + nullify (basic%theta ) + nullify (basic%pi0 ) + nullify (basic%th0 ) + nullify (basic%dn0 ) + nullify (basic%dn0u ) + nullify (basic%dn0v ) + nullify (basic%fcoru ) + nullify (basic%fcorv ) + nullify (basic%cputime ) + return end subroutine nullify_basic !=======================================================================================! diff --git a/BRAMS/src/memory/mem_scalar.f90 b/BRAMS/src/memory/mem_scalar.f90 index a0313ec38..0c635ee84 100644 --- a/BRAMS/src/memory/mem_scalar.f90 +++ b/BRAMS/src/memory/mem_scalar.f90 @@ -91,12 +91,12 @@ subroutine nullify_scalar(scal,naddsc) ! Deallocate arrays do nsc=1,naddsc - if (associated(scal(nsc)%sclp)) nullify (scal(nsc)%sclp) - if (associated(scal(nsc)%sclt)) nullify (scal(nsc)%sclt) - if (associated(scal(nsc)%drydep)) nullify (scal(nsc)%drydep) + nullify (scal(nsc)%sclp) + nullify (scal(nsc)%sclt) + nullify (scal(nsc)%drydep) ! For CATT - if (associated(scal(nsc)%wetdep)) nullify (scal(nsc)%wetdep) - if (associated(scal(nsc)%srcsc)) nullify (scal(nsc)%srcsc) + nullify (scal(nsc)%wetdep) + nullify (scal(nsc)%srcsc) enddo return diff --git a/BRAMS/src/memory/mem_scratch.f90 b/BRAMS/src/memory/mem_scratch.f90 index 32abb138d..d80b34a19 100644 --- a/BRAMS/src/memory/mem_scratch.f90 +++ b/BRAMS/src/memory/mem_scratch.f90 @@ -264,56 +264,56 @@ subroutine nullify_scratch() implicit none !----- Deallocate all scratch arrays ------------------------------------------------! - if (associated(scratch%scr1 )) nullify (scratch%scr1 ) - if (associated(scratch%scr2 )) nullify (scratch%scr2 ) - if (associated(scratch%scr3 )) nullify (scratch%scr3 ) - if (associated(scratch%scr4 )) nullify (scratch%scr4 ) - if (associated(scratch%scr5 )) nullify (scratch%scr5 ) - if (associated(scratch%scr6 )) nullify (scratch%scr6 ) - - if (associated(scratch%vt2da)) nullify (scratch%vt2da) - if (associated(scratch%vt2db)) nullify (scratch%vt2db) - if (associated(scratch%vt2dc)) nullify (scratch%vt2dc) - if (associated(scratch%vt2dd)) nullify (scratch%vt2dd) - if (associated(scratch%vt2de)) nullify (scratch%vt2de) - if (associated(scratch%vt2df)) nullify (scratch%vt2df) - if (associated(scratch%vt2dg)) nullify (scratch%vt2dg) - if (associated(scratch%vt2dh)) nullify (scratch%vt2dh) - if (associated(scratch%vt2di)) nullify (scratch%vt2di) - if (associated(scratch%vt2dj)) nullify (scratch%vt2dj) - if (associated(scratch%vt2dk)) nullify (scratch%vt2dk) - if (associated(scratch%vt2dl)) nullify (scratch%vt2dl) - if (associated(scratch%vt2dm)) nullify (scratch%vt2dm) - if (associated(scratch%vt2dn)) nullify (scratch%vt2dn) - if (associated(scratch%vt2do)) nullify (scratch%vt2do) - if (associated(scratch%vt2dp)) nullify (scratch%vt2dp) - if (associated(scratch%vt2dq)) nullify (scratch%vt2dq) - if (associated(scratch%vt2dr)) nullify (scratch%vt2dr) - if (associated(scratch%vt2ds)) nullify (scratch%vt2ds) - - if (associated(scratch%vt3da)) nullify (scratch%vt3da) - if (associated(scratch%vt3db)) nullify (scratch%vt3db) - if (associated(scratch%vt3dc)) nullify (scratch%vt3dc) - if (associated(scratch%vt3dd)) nullify (scratch%vt3dd) - if (associated(scratch%vt3de)) nullify (scratch%vt3de) - if (associated(scratch%vt3df)) nullify (scratch%vt3df) - if (associated(scratch%vt3dg)) nullify (scratch%vt3dg) - if (associated(scratch%vt3dh)) nullify (scratch%vt3dh) - if (associated(scratch%vt3di)) nullify (scratch%vt3di) - if (associated(scratch%vt3dj)) nullify (scratch%vt3dj) - if (associated(scratch%vt3dk)) nullify (scratch%vt3dk) - if (associated(scratch%vt3dl)) nullify (scratch%vt3dl) - if (associated(scratch%vt3dm)) nullify (scratch%vt3dm) - if (associated(scratch%vt3dn)) nullify (scratch%vt3dn) - if (associated(scratch%vt3do)) nullify (scratch%vt3do) - if (associated(scratch%vt3dp)) nullify (scratch%vt3dp) - if (associated(scratch%vt3dq)) nullify (scratch%vt3dq) - if (associated(scratch%vt3dr)) nullify (scratch%vt3dr) - if (associated(scratch%vt3ds)) nullify (scratch%vt3ds) - - if (associated(scratch%vt4da)) nullify (scratch%vt4da) - if (associated(scratch%vt4db)) nullify (scratch%vt4db) - if (associated(scratch%vt4dc)) nullify (scratch%vt4dc) + nullify (scratch%scr1 ) + nullify (scratch%scr2 ) + nullify (scratch%scr3 ) + nullify (scratch%scr4 ) + nullify (scratch%scr5 ) + nullify (scratch%scr6 ) + + nullify (scratch%vt2da) + nullify (scratch%vt2db) + nullify (scratch%vt2dc) + nullify (scratch%vt2dd) + nullify (scratch%vt2de) + nullify (scratch%vt2df) + nullify (scratch%vt2dg) + nullify (scratch%vt2dh) + nullify (scratch%vt2di) + nullify (scratch%vt2dj) + nullify (scratch%vt2dk) + nullify (scratch%vt2dl) + nullify (scratch%vt2dm) + nullify (scratch%vt2dn) + nullify (scratch%vt2do) + nullify (scratch%vt2dp) + nullify (scratch%vt2dq) + nullify (scratch%vt2dr) + nullify (scratch%vt2ds) + + nullify (scratch%vt3da) + nullify (scratch%vt3db) + nullify (scratch%vt3dc) + nullify (scratch%vt3dd) + nullify (scratch%vt3de) + nullify (scratch%vt3df) + nullify (scratch%vt3dg) + nullify (scratch%vt3dh) + nullify (scratch%vt3di) + nullify (scratch%vt3dj) + nullify (scratch%vt3dk) + nullify (scratch%vt3dl) + nullify (scratch%vt3dm) + nullify (scratch%vt3dn) + nullify (scratch%vt3do) + nullify (scratch%vt3dp) + nullify (scratch%vt3dq) + nullify (scratch%vt3dr) + nullify (scratch%vt3ds) + + nullify (scratch%vt4da) + nullify (scratch%vt4db) + nullify (scratch%vt4dc) return end subroutine nullify_scratch diff --git a/BRAMS/src/memory/mem_scratch1_brams.f90 b/BRAMS/src/memory/mem_scratch1_brams.f90 index 87eeb0a53..4aeb87e52 100644 --- a/BRAMS/src/memory/mem_scratch1_brams.f90 +++ b/BRAMS/src/memory/mem_scratch1_brams.f90 @@ -71,11 +71,11 @@ subroutine nullify_scratch1() ! Deallocate all scratch arrays - if (associated(scratch1%vtu )) nullify (scratch1%vtu ) - if (associated(scratch1%vtv )) nullify (scratch1%vtv ) - if (associated(scratch1%vtw )) nullify (scratch1%vtw ) - if (associated(scratch1%vtp )) nullify (scratch1%vtp ) - if (associated(scratch1%vtscalar )) nullify (scratch1%vtscalar ) + nullify (scratch1%vtu ) + nullify (scratch1%vtv ) + nullify (scratch1%vtw ) + nullify (scratch1%vtp ) + nullify (scratch1%vtscalar ) return diff --git a/BRAMS/src/memory/mem_tend.f90 b/BRAMS/src/memory/mem_tend.f90 index 7d999f7a7..640e491bd 100644 --- a/BRAMS/src/memory/mem_tend.f90 +++ b/BRAMS/src/memory/mem_tend.f90 @@ -171,35 +171,35 @@ subroutine nullify_tend(tend) type(tend_vars), intent(inout) :: tend !------------------------------------------------------------------------------------! - if (associated(tend%ut )) nullify (tend%ut ) - if (associated(tend%vt )) nullify (tend%vt ) - if (associated(tend%wt )) nullify (tend%wt ) - if (associated(tend%pt )) nullify (tend%pt ) - if (associated(tend%tht )) nullify (tend%tht ) - if (associated(tend%rtt )) nullify (tend%rtt ) - if (associated(tend%co2t)) nullify (tend%co2t) - if (associated(tend%tket)) nullify (tend%tket) - if (associated(tend%epst)) nullify (tend%epst) + nullify (tend%ut ) + nullify (tend%vt ) + nullify (tend%wt ) + nullify (tend%pt ) + nullify (tend%tht ) + nullify (tend%rtt ) + nullify (tend%co2t) + nullify (tend%tket) + nullify (tend%epst) !----- TEB_SPM. ---------------------------------------------------------------------! if (teb_spm==1 .and. isource == 1) then - if (associated(gaspart_g(1)%pnot )) nullify (gaspart_g(1)%pnot ) - if (associated(gaspart_g(1)%pno2t )) nullify (gaspart_g(1)%pno2t ) - if (associated(gaspart_g(1)%ppm25t)) nullify (gaspart_g(1)%ppm25t) - if (associated(gaspart_g(1)%pcot )) nullify (gaspart_g(1)%pcot ) - if (associated(gaspart_g(1)%pso2t )) nullify (gaspart_g(1)%pso2t ) - if (associated(gaspart_g(1)%pso4t )) nullify (gaspart_g(1)%pso4t ) - if (associated(gaspart_g(1)%paert )) nullify (gaspart_g(1)%paert ) - if (associated(gaspart_g(1)%pvoct )) nullify (gaspart_g(1)%pvoct ) + nullify (gaspart_g(1)%pnot ) + nullify (gaspart_g(1)%pno2t ) + nullify (gaspart_g(1)%ppm25t) + nullify (gaspart_g(1)%pcot ) + nullify (gaspart_g(1)%pso2t ) + nullify (gaspart_g(1)%pso4t ) + nullify (gaspart_g(1)%paert ) + nullify (gaspart_g(1)%pvoct ) if (ichemi==1) then - if (associated(gaspart_g(1)%po3t )) nullify (gaspart_g(1)%po3t ) - if (associated(gaspart_g(1)%prhcot)) nullify (gaspart_g(1)%prhcot) - if (associated(gaspart_g(1)%pho2t )) nullify (gaspart_g(1)%pho2t ) - if (associated(gaspart_g(1)%po3pt )) nullify (gaspart_g(1)%po3pt ) - if (associated(gaspart_g(1)%po1dt )) nullify (gaspart_g(1)%po1dt ) - if (associated(gaspart_g(1)%phot )) nullify (gaspart_g(1)%phot ) - if (associated(gaspart_g(1)%proot )) nullify (gaspart_g(1)%proot ) + nullify (gaspart_g(1)%po3t ) + nullify (gaspart_g(1)%prhcot) + nullify (gaspart_g(1)%pho2t ) + nullify (gaspart_g(1)%po3pt ) + nullify (gaspart_g(1)%po1dt ) + nullify (gaspart_g(1)%phot ) + nullify (gaspart_g(1)%proot ) end if end if diff --git a/BRAMS/src/memory/mem_varinit.f90 b/BRAMS/src/memory/mem_varinit.f90 index 2e617214d..a12c09b56 100644 --- a/BRAMS/src/memory/mem_varinit.f90 +++ b/BRAMS/src/memory/mem_varinit.f90 @@ -114,24 +114,24 @@ subroutine nullify_varinit(varinit) type (varinit_vars) :: varinit - if (associated(varinit%varup)) nullify (varinit%varup) - if (associated(varinit%varvp)) nullify (varinit%varvp) - if (associated(varinit%varpp)) nullify (varinit%varpp) - if (associated(varinit%vartp)) nullify (varinit%vartp) - if (associated(varinit%varrp)) nullify (varinit%varrp) - if (associated(varinit%varop)) nullify (varinit%varop) - if (associated(varinit%varuf)) nullify (varinit%varuf) - if (associated(varinit%varvf)) nullify (varinit%varvf) - if (associated(varinit%varpf)) nullify (varinit%varpf) - if (associated(varinit%vartf)) nullify (varinit%vartf) - if (associated(varinit%varrf)) nullify (varinit%varrf) - if (associated(varinit%varof)) nullify (varinit%varof) - if (associated(varinit%varwts)) nullify (varinit%varwts) - - if (associated(varinit%varcph)) nullify (varinit%varcph) - if (associated(varinit%varcfh)) nullify (varinit%varcfh) - if (associated(varinit%varrph)) nullify (varinit%varrph) - if (associated(varinit%varrfh)) nullify (varinit%varrfh) + nullify (varinit%varup) + nullify (varinit%varvp) + nullify (varinit%varpp) + nullify (varinit%vartp) + nullify (varinit%varrp) + nullify (varinit%varop) + nullify (varinit%varuf) + nullify (varinit%varvf) + nullify (varinit%varpf) + nullify (varinit%vartf) + nullify (varinit%varrf) + nullify (varinit%varof) + nullify (varinit%varwts) + + nullify (varinit%varcph) + nullify (varinit%varcfh) + nullify (varinit%varrph) + nullify (varinit%varrfh) return end subroutine nullify_varinit diff --git a/BRAMS/src/memory/rams_mem_alloc.f90 b/BRAMS/src/memory/rams_mem_alloc.f90 index e29f44dbe..3c0e8329e 100644 --- a/BRAMS/src/memory/rams_mem_alloc.f90 +++ b/BRAMS/src/memory/rams_mem_alloc.f90 @@ -72,6 +72,13 @@ subroutine rams_mem_alloc(proc_type) , zero_mass & ! subroutine , filltab_mass ! ! subroutine use turb_coms , only : assign_turb_params ! ! subroutine + use mem_mnt_advec , only : iadvec & ! intent(in) + , advec_g & ! intent(out) + , advecm_g & ! intent(out) + , nullify_advec & ! subroutine + , alloc_advec & ! subroutine + , zero_advec & ! subroutine + , filltab_advec ! ! subroutine use mem_grell_param ! ! scalar parameters use mem_scratch1_grell ! ! scratch 1 use mem_scratch2_grell ! ! scratch 2 @@ -83,7 +90,7 @@ subroutine rams_mem_alloc(proc_type) integer , intent(in) :: proc_type !----- Local Variables: ----------------------------------------------------------------! integer, pointer , dimension(:) :: nmzp,nmxp,nmyp - integer :: ng,nv,imean,na,ne,ntpts + integer :: ng,nv,imean,na,ne,ntpts,id logical :: Alloc_Old_Grell_Flag !----- Local variables because of TEB_SPM ----------------------------------------------! type(gaspart_vars), pointer :: gaspart_p @@ -304,6 +311,27 @@ subroutine rams_mem_alloc(proc_type) !---------------------------------------------------------------------------------------! + !----- Allocate Micro variables data type. ---------------------------------------------! + if (iadvec == 2) then + write (unit=*,fmt=*) ' [+] Advec allocation on node ',mynum,'...' + allocate(advec_g(ngrids),advecm_g(ngrids)) + do ng=1,ngrids + call nullify_advec(advec_g(ng)) + call nullify_advec(advecm_g(ng)) + call alloc_advec(advec_g(ng),nmzp(ng),nmxp(ng),nmyp(ng)) + if (imean == 1) then + call alloc_advec(advecm_g(ng),nmzp(ng),nmxp(ng),nmyp(ng)) + elseif (imean == 0) then + call alloc_advec(advecm_g(ng),1,1,1) + end if + call zero_advec(advec_g(ng)) + call zero_advec(advecm_g(ng)) + call filltab_advec(advec_g(ng),advecm_g(ng),imean,nmzp(ng),nmxp(ng),nmyp(ng),ng) + end do + end if + !---------------------------------------------------------------------------------------! + + !----- Allocate radiate variables data type --------------------------------------------! write (unit=*,fmt=*) ' [+] Radiate allocation on node ',mynum,'...' @@ -585,39 +613,35 @@ subroutine rams_mem_alloc(proc_type) allocate(extra3d (na_extra3d,ngrids)) allocate(extra2dm(na_extra2d,ngrids)) allocate(extra3dm(na_extra3d,ngrids)) - call nullify_extra2d(extra2d,na_extra2d,ngrids) - call nullify_extra2d(extra2dm,na_extra2d,ngrids) - call nullify_extra3d(extra3d,na_extra3d,ngrids) - call nullify_extra3d(extra3dm,na_extra3d,ngrids) - do ng=1,ngrids - call alloc_extra2d(extra2d,nmxp(ng),nmyp(ng),na_extra2d,ng) - call zero_extra2d(extra2d,na_extra2d,ng) - if (imean == 1) then - call alloc_extra2d(extra2dm,nmxp(ng),nmyp(ng),na_extra2d,ng) - call zero_extra2d(extra2dm,na_extra2d,ng) - else - call alloc_extra2d(extra2dm,1,1,na_extra2d,ng) - call zero_extra2d(extra2dm,na_extra2d,ng) - end if - call alloc_extra3d(extra3d,nmzp(ng),nmxp(ng),nmyp(ng),na_extra3d,ng) - call zero_extra3d(extra3d,na_extra3d,ng) - if (imean == 1) then - call alloc_extra3d(extra3dm, & - nmzp(ng),nmxp(ng),nmyp(ng),na_extra3d,ng) - call zero_extra3d(extra3dm,na_extra3d,ng) - else - call alloc_extra3d(extra3dm,1,1,1,na_extra3d,ng) - call zero_extra3d(extra3dm,na_extra3d,ng) - end if - end do do ng=1,ngrids do na=1,na_extra2d - call filltab_extra2d(extra2d(na,ng),extra2dm(na,ng),imean, & - nmxp(ng),nmyp(ng),ng,na) + call nullify_extra2d(extra2d(na,ng)) + call nullify_extra2d(extra2dm(na,ng)) + call alloc_extra2d(extra2d(na,ng),nmxp(ng),nmyp(ng)) + if (imean == 1) then + call alloc_extra2d(extra2dm(na,ng),nmxp(ng),nmyp(ng)) + else + call alloc_extra2d(extra2dm(na,ng),1,1) + end if + call zero_extra2d(extra2d(na,ng)) + call zero_extra2d(extra2dm(na,ng)) + call filltab_extra2d(extra2d(na,ng),extra2dm(na,ng),imean,nmxp(ng),nmyp(ng) & + ,ng,na) end do + do na=1,na_extra3d - call filltab_extra3d(extra3d(na,ng),extra3dm(na,ng),imean, & - nmzp(ng),nmxp(ng),nmyp(ng),ng,na) + call nullify_extra3d(extra3d(na,ng)) + call nullify_extra3d(extra3dm(na,ng)) + call alloc_extra3d(extra3d(na,ng),nmzp(ng),nmxp(ng),nmyp(ng)) + if (imean == 1) then + call alloc_extra3d(extra3dm(na,ng),nmzp(ng),nmxp(ng),nmyp(ng)) + else + call alloc_extra3d(extra3dm(na,ng),1,1,1) + end if + call zero_extra3d(extra3d(na,ng)) + call zero_extra3d(extra3dm(na,ng)) + call filltab_extra3d(extra3d(na,ng),extra3dm(na,ng),imean,nmzp(ng),nmxp(ng) & + ,nmyp(ng),ng,na) end do end do end if @@ -636,17 +660,16 @@ subroutine rams_mem_alloc(proc_type) allocate(carma(ngrids)) allocate(carma_m(ngrids)) do ng=1,ngrids - call nullify_carma(carma,ng) - call alloc_carma(carma,ng,nmxp(ng),nmyp(ng),nwave) - call zero_carma(carma,ng) - call nullify_carma(carma_m,ng) + call nullify_carma(carma(ng)) + call nullify_carma(carma_m(ng)) + call alloc_carma(carma(ng),nmxp(ng),nmyp(ng),nwave) if(imean == 1) then - call alloc_carma(carma_m,ng,nmxp(ng),nmyp(ng),nwave) - call zero_carma(carma_m,ng) + call alloc_carma(carma_m(ng),nmxp(ng),nmyp(ng),nwave) else - call alloc_carma(carma_m,ng,1,1,nwave) - call zero_carma(carma_m,ng) + call alloc_carma(carma_m(ng),1,1,nwave) end if + call zero_carma(carma(ng)) + call zero_carma(carma_m(ng)) call filltab_carma(carma(ng),carma_m(ng),ng,imean,nmxp(ng),nmyp(ng),nwave) end do diff --git a/BRAMS/src/memory/var_tables.f90 b/BRAMS/src/memory/var_tables.f90 index 4949ef413..0d59f3b22 100644 --- a/BRAMS/src/memory/var_tables.f90 +++ b/BRAMS/src/memory/var_tables.f90 @@ -1,57 +1,93 @@ -!############################# Change Log ################################## -! 5.0.0 -! -!########################################################################### -! Copyright (C) 1990, 1995, 1999, 2000, 2003 - All Rights Reserved -! Regional Atmospheric Modeling System - RAMS -!########################################################################### +!============================= Change Log =================================================! +! 5.0.0 ! +! ! +!==========================================================================================! +! Copyright (C) 1990, 1995, 1999, 2000, 2003 - All Rights Reserved ! +! Regional Atmospheric Modeling System - RAMS ! +!==========================================================================================! +!==========================================================================================! -Module var_tables - ! Maximum number of variables of all types (3d + 2d + leaf) -integer, parameter :: maxvars=1600 - ! Define data type for main variable table -type var_tables_r - - real, dimension(:), pointer :: var_p,var_m - integer :: npts, idim_type - integer :: ihist,ianal,imean,ilite,impti,impt1,impt2,impt3,irecycle - character (len=16) :: name - -end type var_tables_r - ! Main variable table allocated to (maxvars,maxgrds) -type(var_tables_r), allocatable :: vtab_r(:,:) +!==========================================================================================! +!==========================================================================================! +! This module contains structures that will set up the global variable table in BRAMS. ! +!------------------------------------------------------------------------------------------! +module var_tables - ! "nvgrids" is "ngrids", for convenience -integer :: nvgrids + !----- Maximum number of variables of all types (3d + 2d + leaf + CARMA + Grell). ------! + integer, parameter :: maxvars=3200 + !---------------------------------------------------------------------------------------! - ! number of variables for each grid, allocated to "ngrids" -integer, allocatable :: num_var(:) + !----- Define data type for main variable table. ---------------------------------------! + type var_tables_r + + real, dimension(:), pointer :: var_p ! Pointer to instantaneous variable + real, dimension(:), pointer :: var_m ! Pointer to mean variable + integer :: npts ! Number of points + integer :: idim_type ! Variable type + integer :: ihist ! Variable is written to history + integer :: ianal ! Variable is written to analysis + integer :: imean ! Variable is written to mean analysis + integer :: ilite ! Variable is written to light analysis + integer :: impti ! Variable is sent out during initialisation + integer :: impt1 ! Lateral bnd. cond. at regular time step + integer :: impt2 ! Lateral bnd. cond. at acoustic time step + integer :: impt3 ! Variable is to be sent back at analysis + integer :: iadvt ! Advection time step (T variables) + integer :: iadvu ! Advection time step (U variables) + integer :: iadvv ! Advection time step (V variables) + integer :: iadvw ! Advection time step (W variables) + integer :: irecycle ! Recycle variable + character(len=16) :: name ! Variable name + end type var_tables_r + !---------------------------------------------------------------------------------------! - ! Define data type for scalar variable table -type scalar_table - - real, dimension(:), pointer :: var_p,var_t - character (len=16) :: name - ! ALF - real, pointer :: a_var_p(:), a_var_t(:) + !----- Main variable table allocated to (maxvars,maxgrds). -----------------------------! + type(var_tables_r), dimension(:,:), allocatable :: vtab_r + !---------------------------------------------------------------------------------------! -end type scalar_table - ! Scalar variable table allocated to (maxsclr,maxgrds) -type(scalar_table), allocatable :: scalar_tab(:,:) + !----- "nvgrids" is "ngrids", for convenience. -----------------------------------------! + integer :: nvgrids + !---------------------------------------------------------------------------------------! - ! number of scalars for each grid, allocated to "ngrids" -integer, allocatable :: num_scalar(:) + !----- Number of variables for each grid, allocated to "ngrids". -----------------------! + integer, dimension(:), allocatable :: num_var + !---------------------------------------------------------------------------------------! -End Module var_tables + + !----- Define data type for scalar variable table. -------------------------------------! + type scalar_table + real, dimension(:), pointer :: var_p + real, dimension(:), pointer :: var_t + character (len=16) :: name + real, dimension(:), pointer :: a_var_p + real, dimension(:), pointer :: a_var_t + end type scalar_table + !---------------------------------------------------------------------------------------! + + + + !----- Scalar variable table allocated to (maxsclr,maxgrds). ---------------------------! + type(scalar_table), dimension(:,:), allocatable :: scalar_tab + !---------------------------------------------------------------------------------------! + + + !----- Number of scalars for each grid, allocated to "ngrids". -------------------------! + integer, dimension(:), allocatable :: num_scalar + !---------------------------------------------------------------------------------------! + + +end module var_tables +!==========================================================================================! +!==========================================================================================! diff --git a/BRAMS/src/memory/vtab_fill.f90 b/BRAMS/src/memory/vtab_fill.f90 index 3fb5884cc..8e7e1f1a2 100644 --- a/BRAMS/src/memory/vtab_fill.f90 +++ b/BRAMS/src/memory/vtab_fill.f90 @@ -5,260 +5,333 @@ ! Copyright (C) 1990, 1995, 1999, 2000, 2003 - All Rights Reserved ! ! Regional Atmospheric Modeling System - RAMS ! !==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +! This subroutine will assign pointers to the variable table, and assign the values of ! +! several flags to determine whether/when a variable should be written to files, and to ! +! be exchanged amongst nodes. ! +!------------------------------------------------------------------------------------------! subroutine vtables2(var,varm,ng,npts,imean,tabstr) - use grid_dims, only : str_len + use grid_dims , only : str_len ! ! intent(in) use var_tables implicit none - integer, intent(in) :: ng,npts,imean - real, dimension (npts), target :: var,varm - character (len=*), intent(in) :: tabstr + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: ng + integer , intent(in) :: npts + integer , intent(in) :: imean + real , dimension (npts), target :: var + real , dimension (npts), target :: varm + character(len=*) , intent(in) :: tabstr + !---- Local variables. -----------------------------------------------------------------! + character(len=str_len) :: line + character(len=1) :: cdimen + character(len=1) :: ctype + character(len=32) , dimension(10) :: tokens + character(len=8) :: cname + character(len=8) :: ctab + integer :: ntok + integer :: nt + integer :: nv + character(len=1) , parameter :: toksep = ':' + !---------------------------------------------------------------------------------------! - character (len=str_len) ::line - character (len=1) ::toksep=':', cdimen,ctype - character (len=32) ::tokens(10) - character (len=8) :: cname,ctab - integer :: ntok,nt,nv - + !----- Split the tokens and save them in tokens. ---------------------------------------! call tokenize1(tabstr,tokens,ntok,toksep) + !---------------------------------------------------------------------------------------! + + + !----- Add the variable to the list, and save nv as the variable "ID". -----------------! num_var(ng)=num_var(ng)+1 nv=num_var(ng) + !---------------------------------------------------------------------------------------! + + + !----- Point the variables. ------------------------------------------------------------! vtab_r(nv,ng)%var_p => var vtab_r(nv,ng)%var_m => varm + !---------------------------------------------------------------------------------------! - vtab_r(nv,ng)%name=tokens(1) - vtab_r(nv,ng)%npts=npts - read(tokens(2),*) vtab_r(nv,ng)%idim_type - !print*,'tab:',nv,ng,vtab_r(nv,ng)%name ,vtab_r(nv,ng)%npts + !----- Token(1) must be variable name. -------------------------------------------------! + vtab_r(nv,ng)%name = tokens(1) + !---------------------------------------------------------------------------------------! - vtab_r(nv,ng)%ihist=0 - vtab_r(nv,ng)%ianal=0 - vtab_r(nv,ng)%imean=imean - vtab_r(nv,ng)%ilite=0 - vtab_r(nv,ng)%impti=0 - vtab_r(nv,ng)%impt1=0 - vtab_r(nv,ng)%impt2=0 - vtab_r(nv,ng)%impt3=0 - vtab_r(nv,ng)%irecycle=0 + !----- Variable size. ------------------------------------------------------------------! + vtab_r(nv,ng)%npts = npts + !---------------------------------------------------------------------------------------! + + !----- Token(2) is the dimension, read it so it becomes an integer. --------------------! + read (tokens(2),fmt=*) vtab_r(nv,ng)%idim_type + !---------------------------------------------------------------------------------------! + + + + !----- Initialise all flags as zeroes (or imean). --------------------------------------! + vtab_r(nv,ng)%ihist = 0 + vtab_r(nv,ng)%ianal = 0 + vtab_r(nv,ng)%imean = imean + vtab_r(nv,ng)%ilite = 0 + vtab_r(nv,ng)%impti = 0 + vtab_r(nv,ng)%impt1 = 0 + vtab_r(nv,ng)%impt2 = 0 + vtab_r(nv,ng)%impt3 = 0 + vtab_r(nv,ng)%iadvt = 0 + vtab_r(nv,ng)%iadvu = 0 + vtab_r(nv,ng)%iadvv = 0 + vtab_r(nv,ng)%iadvw = 0 + vtab_r(nv,ng)%irecycle = 0 + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! Loop over the remaining tokens, and switch the flag to 1 for those actions that ! + ! are listed in the token list. ! + !---------------------------------------------------------------------------------------! do nt=3,ntok ctab=tokens(nt) - if(ctab == 'hist' ) then - vtab_r(nv,ng)%ihist=1 - elseif(ctab == 'anal' ) then - vtab_r(nv,ng)%ianal=1 - elseif(ctab == 'lite' ) then - vtab_r(nv,ng)%ilite=1 - elseif(ctab == 'mpti' ) then - vtab_r(nv,ng)%impti=1 - elseif(ctab == 'mpt1' ) then - vtab_r(nv,ng)%impt1=1 - elseif(ctab == 'mpt2' ) then - vtab_r(nv,ng)%impt2=1 - elseif(ctab == 'mpt3' ) then - vtab_r(nv,ng)%impt3=1 - elseif(ctab == 'recycle' ) then - vtab_r(nv,ng)%irecycle=1 - else - print*, 'Illegal table specification for var:', tokens(1),ctab - stop 'bad var table' - endif - - enddo + select case(trim(ctab)) + case ('hist') + vtab_r(nv,ng)%ihist = 1 + + case ('anal') + vtab_r(nv,ng)%ianal = 1 + + case ('lite') + vtab_r(nv,ng)%ilite = 1 + + case ('mpti') + vtab_r(nv,ng)%impti = 1 + + case ('mpt1') + vtab_r(nv,ng)%impt1 = 1 + + case ('mpt2') + vtab_r(nv,ng)%impt2 = 1 + + case ('mpt3') + vtab_r(nv,ng)%impt3 = 1 + + case ('advt') + vtab_r(nv,ng)%iadvt = 1 + + case ('advu') + vtab_r(nv,ng)%iadvu = 1 + + case ('advv') + vtab_r(nv,ng)%iadvv = 1 + + case ('advw') + vtab_r(nv,ng)%iadvw = 1 + + case ('recycle') + vtab_r(nv,ng)%irecycle = 1 + + case default + + write(unit=*,fmt='(3(a,1x))') 'Illegal table specification for var:' & + ,tokens(1),ctab + call abort_run('Bad settings.','vtables2','vtab_fill') + end select + end do + !---------------------------------------------------------------------------------------! return end subroutine vtables2 +!==========================================================================================! +!==========================================================================================! -!------------------------------------------------------------------------- -subroutine lite_varset(proc_type) - use var_tables, only: & - nvgrids, & ! INTENT(IN) - vtab_r, & ! INTENT(INOUT) - num_var ! INTENT(IN) - use io_params, only: & - nlite_vars, & ! INTENT(IN) - lite_vars ! INTENT(IN) - - implicit none - - ! Arguments: - integer, intent(in) :: proc_type - - ! Local variables: - integer :: nv,ng,nvl,ifound - + + +!==========================================================================================! +!==========================================================================================! +subroutine lite_varset(proc_type) + + use var_tables, only : nvgrids & ! intent(in) + , vtab_r & ! intent(inout) + , num_var ! ! intent(in) + use io_params , only : nlite_vars & ! INTENT(IN) + , lite_vars ! ! INTENT(IN) + implicit none - ! Loop over each variable input in namelist "LITE_VARS" and set - ! lite flag in var_tables + !----- Arguments. ----------------------------------------------------------------------! + integer, intent(in) :: proc_type + !----- Local variables. ----------------------------------------------------------------! + integer :: nv + integer :: ng + integer :: nvl + integer :: ifound + !---------------------------------------------------------------------------------------! + - do ng = 1,nvgrids - vtab_r(1:num_var(ng),ng)%ilite = 0 - enddo + !---------------------------------------------------------------------------------------! + ! Loop over each variable input in namelist "LITE_VARS" and set lite flag in ! + ! var_tables. ! + !---------------------------------------------------------------------------------------! + do ng = 1,nvgrids + vtab_r(1:num_var(ng),ng)%ilite = 0 + end do + !---------------------------------------------------------------------------------------! - do nvl=1,nlite_vars - ifound=0 - - do ng=1,nvgrids - - do nv=1,num_var(ng) - - if (vtab_r(nv,ng)%name == lite_vars(nvl) ) then - vtab_r(nv,ng)%ilite = 1 - ifound=1 - endif - - enddo - - enddo - - if (proc_type==0 .or. proc_type==1) then !Output only in Master Process - if(ifound == 0) then - print*,'!---------------------------------------------------------' - print*,'! LITE_VARS variable does not exist in main variable table' - print*,'! variable name-->',lite_vars(nvl),'<--' - print*,'!---------------------------------------------------------' - else - print*,'!---------------------------------------------------------' - print*,'! LITE_VARS variable added--->',trim(lite_vars(nvl)) - print*,'!---------------------------------------------------------' - endif - endif - - enddo + + !---------------------------------------------------------------------------------------! + do nvl=1,nlite_vars + ifound=0 + + do ng=1,nvgrids + do nv=1,num_var(ng) + if (vtab_r(nv,ng)%name == lite_vars(nvl) ) then + vtab_r(nv,ng)%ilite = 1 + ifound = 1 + end if + end do + end do + + + if (proc_type==0 .or. proc_type==1) then + !----- Output only in master process. --------------------------------------------! + if (ifound == 0) then + write(unit=*,fmt='(a)') '!---------------------------------------------------' + write(unit=*,fmt='(4a)') '! LITE_VARS variable does not exist in main ' & + ,'variable table: -->',lite_vars(nvl),'<--' + write(unit=*,fmt='(a)') '!---------------------------------------------------' + else + write(unit=*,fmt='(a)') '!---------------------------------------------------' + write(unit=*,fmt='(3a)') '! LITE_VARS variable added -->', trim(lite_vars(nvl)) + write(unit=*,fmt='(a)') '!---------------------------------------------------' + end if + end if + end do return end subroutine lite_varset - -!------------------------------------------------------------------------- - - subroutine vtables_scalar(npts,varp,vart,ng,tabstr) - use grid_dims, only : str_len +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +subroutine vtables_scalar(npts,varp,vart,ng,tabstr) + use grid_dims , only : str_len ! ! intent(in) use var_tables implicit none - integer, intent(in) :: npts - real, dimension(npts), target :: varp,vart - integer, intent(in) :: ng - character (len=*), intent(in) :: tabstr - - character (len=str_len) ::line - character (len=1) ::toksep=':' - character (len=32) ::tokens(10) - character (len=16) :: cname,ctab - - integer :: ntok,nv,isnum,ns - + !------ Arguments. ---------------------------------------------------------------------! + integer , intent(in) :: npts + real , dimension(npts), target :: varp + real , dimension(npts), target :: vart + integer , intent(in) :: ng + character (len=*) , intent(in) :: tabstr + !------ Local variables. ---------------------------------------------------------------! + character (len=str_len) :: line + character (len=32) , dimension(10) :: tokens + character (len=16) :: cname + character (len=16) :: ctab + integer :: ntok + integer :: nv + integer :: isnum + integer :: ns + character (len=1) , parameter :: toksep = ':' + !---------------------------------------------------------------------------------------! + + + !------ Split the tokens. --------------------------------------------------------------! call tokenize1(tabstr,tokens,ntok,toksep) - cname=tokens(1) -! ctab=tokens(2) - -! See if this scalar name is already in the table... - - isnum=0 - -! do ns=1,num_scalar(ng) -! if(cname == scalar_tab(ns,ng)%name) then -! isnum=ns -! exit -! endif -! enddo - -! Fill in existing table slot or make new scalar slot - -! if (isnum == 0) then - num_scalar(ng)=num_scalar(ng)+1 - nv=num_scalar(ng) - scalar_tab(nv,ng)%name = cname -! else -! nv=isnum -! endif + cname = tokens(1) + isnum = 0 + !---------------------------------------------------------------------------------------! + + !------ Fill in existing table slot or make new scalar slot. ---------------------------! + num_scalar(ng) = num_scalar(ng)+1 + nv = num_scalar(ng) + scalar_tab(nv,ng)%name = cname + !---------------------------------------------------------------------------------------! + + + !------ Match the variable and the tendency. -------------------------------------------! scalar_tab(nv,ng)%var_p => varp scalar_tab(nv,ng)%var_t => vart - -! if(ctab == 'sclp' ) then -! scalar_tab(nv,ng)%varp => varp -! elseif(ctab == 'sclt' ) then -! scalar_tab(nv,ng)%vart => vart -! else -! print*, 'Illegal scalar table specification for var:', cname -! stop 'bad scalar table' -! endif - + !---------------------------------------------------------------------------------------! + return - end - -!------------------------------------------------------------------------- - - subroutine vtables_scalar_new(varp,vart,ng,tabstr,elements) - - use var_tables - use grid_dims, only : str_len - implicit none - integer :: elements !ALF - real, target :: varp(elements), vart(elements) - integer, intent(in) :: ng - character (len=*), intent(in) :: tabstr - - character (len=str_len) ::line - character (len=1) ::toksep=':' - character (len=32) ::tokens(10) - character (len=16) :: cname,ctab - - integer :: ntok,nv,isnum,ns, i - - call tokenize1(tabstr,tokens,ntok,toksep) - cname=tokens(1) - ! ctab=tokens(2) - - ! See if this scalar name is already in the table... - - isnum=0 - - ! do ns=1,num_scalar(ng) - ! if(cname == scalar_tab(ns,ng)%name) then - ! isnum=ns - ! exit - ! endif - ! enddo - - ! Fill in existing table slot or make new scalar slot - - ! if (isnum == 0) then - !num_scalar(ng)=num_scalar(ng)+1 - nv=num_scalar(ng) - !scalar_tab(nv,ng)%name = cname - ! else - ! nv=isnum - ! endif - - !scalar_tab(nv,ng)%var_p => varp - !scalar_tab(nv,ng)%var_t => vart - - ! ALF - scalar_tab(nv,ng)%a_var_p => varp(:) - scalar_tab(nv,ng)%a_var_t => vart(:) - - ! - ! - - ! if(ctab == 'sclp' ) then - ! scalar_tab(nv,ng)%varp => varp - ! elseif(ctab == 'sclt' ) then - ! scalar_tab(nv,ng)%vart => vart - ! else - ! print*, 'Illegal scalar table specification for var:', cname - ! stop 'bad scalar table' - ! endif - - return - end subroutine vtables_scalar_new +end subroutine vtables_scalar +!==========================================================================================! +!==========================================================================================! + + + + + +!==========================================================================================! +!==========================================================================================! +subroutine vtables_scalar_new(varp,vart,ng,tabstr,elements) + + use var_tables + use grid_dims , only : str_len + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: elements + real , dimension(elements), target :: varp + real , dimension(elements), target :: vart + integer , intent(in) :: ng + character (len=*) , intent(in) :: tabstr + !----- Local variables. ----------------------------------------------------------------! + character (len=str_len) :: line + character (len=32) , dimension(10) :: tokens + character (len=16) :: cname + character (len=16) :: ctab + character (len=1) , parameter :: toksep = ':' + !----- Local variables. ----------------------------------------------------------------! + integer :: ntok + integer :: nv + integer :: isnum + integer :: ns + integer :: i + !---------------------------------------------------------------------------------------! + + + !----- Split the tokens. ---------------------------------------------------------------! + call tokenize1(tabstr,tokens,ntok,toksep) + !---------------------------------------------------------------------------------------! + + + !----- Split the tokens. ---------------------------------------------------------------! + cname = tokens(1) + !---------------------------------------------------------------------------------------! + + + !----- Check whether this scalar name is already in the table. -------------------------! + isnum = 0 + !---------------------------------------------------------------------------------------! + + + + nv = num_scalar(ng) + scalar_tab(nv,ng)%a_var_p => varp(:) + scalar_tab(nv,ng)%a_var_t => vart(:) + + return +end subroutine vtables_scalar_new +!==========================================================================================! +!==========================================================================================! diff --git a/BRAMS/src/micro/mem_micro.f90 b/BRAMS/src/micro/mem_micro.f90 index bff36d0aa..031c0b59c 100644 --- a/BRAMS/src/micro/mem_micro.f90 +++ b/BRAMS/src/micro/mem_micro.f90 @@ -149,41 +149,41 @@ subroutine nullify_micro(micro) type (micro_vars) :: micro !------------------------------------------------------------------------------------! - if (associated(micro%rcp )) nullify (micro%rcp ) - if (associated(micro%rrp )) nullify (micro%rrp ) - if (associated(micro%rpp )) nullify (micro%rpp ) - if (associated(micro%rsp )) nullify (micro%rsp ) - if (associated(micro%rap )) nullify (micro%rap ) - if (associated(micro%rgp )) nullify (micro%rgp ) - if (associated(micro%rhp )) nullify (micro%rhp ) - if (associated(micro%ccp )) nullify (micro%ccp ) - if (associated(micro%crp )) nullify (micro%crp ) - if (associated(micro%cpp )) nullify (micro%cpp ) - if (associated(micro%csp )) nullify (micro%csp ) - if (associated(micro%cap )) nullify (micro%cap ) - if (associated(micro%cgp )) nullify (micro%cgp ) - if (associated(micro%chp )) nullify (micro%chp ) - if (associated(micro%cccnp )) nullify (micro%cccnp ) - if (associated(micro%cifnp )) nullify (micro%cifnp ) - if (associated(micro%q2 )) nullify (micro%q2 ) - if (associated(micro%q6 )) nullify (micro%q6 ) - if (associated(micro%q7 )) nullify (micro%q7 ) - - if (associated(micro%accpr )) nullify (micro%accpr ) - if (associated(micro%accpp )) nullify (micro%accpp ) - if (associated(micro%accps )) nullify (micro%accps ) - if (associated(micro%accpa )) nullify (micro%accpa ) - if (associated(micro%accpg )) nullify (micro%accpg ) - if (associated(micro%accph )) nullify (micro%accph ) - if (associated(micro%pcprr )) nullify (micro%pcprr ) - if (associated(micro%pcprp )) nullify (micro%pcprp ) - if (associated(micro%pcprs )) nullify (micro%pcprs ) - if (associated(micro%pcpra )) nullify (micro%pcpra ) - if (associated(micro%pcprg )) nullify (micro%pcprg ) - if (associated(micro%pcprh )) nullify (micro%pcprh ) - if (associated(micro%pcpg )) nullify (micro%pcpg ) - if (associated(micro%qpcpg )) nullify (micro%qpcpg ) - if (associated(micro%dpcpg )) nullify (micro%dpcpg ) + nullify (micro%rcp ) + nullify (micro%rrp ) + nullify (micro%rpp ) + nullify (micro%rsp ) + nullify (micro%rap ) + nullify (micro%rgp ) + nullify (micro%rhp ) + nullify (micro%ccp ) + nullify (micro%crp ) + nullify (micro%cpp ) + nullify (micro%csp ) + nullify (micro%cap ) + nullify (micro%cgp ) + nullify (micro%chp ) + nullify (micro%cccnp ) + nullify (micro%cifnp ) + nullify (micro%q2 ) + nullify (micro%q6 ) + nullify (micro%q7 ) + + nullify (micro%accpr ) + nullify (micro%accpp ) + nullify (micro%accps ) + nullify (micro%accpa ) + nullify (micro%accpg ) + nullify (micro%accph ) + nullify (micro%pcprr ) + nullify (micro%pcprp ) + nullify (micro%pcprs ) + nullify (micro%pcpra ) + nullify (micro%pcprg ) + nullify (micro%pcprh ) + nullify (micro%pcpg ) + nullify (micro%qpcpg ) + nullify (micro%dpcpg ) return end subroutine nullify_micro diff --git a/BRAMS/src/micro/mic_coll.f90 b/BRAMS/src/micro/mic_coll.f90 index c80efac1f..4b176d6ed 100644 --- a/BRAMS/src/micro/mic_coll.f90 +++ b/BRAMS/src/micro/mic_coll.f90 @@ -175,7 +175,7 @@ end subroutine auto_accret subroutine effxy(m1) use micphys - use rconstants, only : qliqt3,t00 + use rconstants, only : uiliqt3,t00 use micro_coms, only : ticegrowth implicit none @@ -279,7 +279,7 @@ subroutine effxy(m1) if (availcat(6)) then graupelloop: do k = k1(6),k2(6) if (rx(k,6) < rxmin(6)) cycle graupelloop - if (qr(k,6) > rx(k,6)*qliqt3) then + if (qr(k,6) > rx(k,6)*uiliqt3) then eff(k,7) = 1.0 else eff(k,7) = min(0.2,10. ** (0.035 * (tx(k,6)-t00) - 0.7)) @@ -293,7 +293,7 @@ subroutine effxy(m1) hailloop:do k = k1(7),k2(7) if (rx(k,7) < rxmin(7)) cycle hailloop - if (qr(k,7) > rx(k,7)*qliqt3) then + if (qr(k,7) > rx(k,7)*uiliqt3) then eff(k,8) = 1.0 else eff(k,8) = min(0.2,10. ** (0.035 * (tx(k,7)-t00) - 0.7)) @@ -566,7 +566,7 @@ subroutine col2(mx,my,mz,mc2,j1,j2,dtlt) use rconstants use micphys - use therm_lib, only : qtk + use therm_lib, only : uint2tl use micro_coms, only : alpha_coll2,beta_coll2 implicit none @@ -631,7 +631,7 @@ subroutine col2(mx,my,mz,mc2,j1,j2,dtlt) qrcoal = qrcx + qrcy qcoal = qrcoal / max(1.e-13,rcoal) - call qtk(qcoal,tcoal,fracliq) + call uint2tl(qcoal,tcoal,fracliq) tcoal = tcoal - t00 coalliq = rcoal * fracliq @@ -712,7 +712,7 @@ end subroutine col2 subroutine col3(mx,my,mz,j1,j2) use micphys - use therm_lib, only : qtk + use therm_lib, only : uint2tl use micro_coms, only : alpha_coll3,beta_coll3 use rconstants, only : t00 @@ -766,7 +766,7 @@ subroutine col3(mx,my,mz,j1,j2) qrcoal = qrcx + qrcy qcoal = qrcoal / (1.e-20 + rcoal) - call qtk(qcoal,tcoal,fracliq) + call uint2tl(qcoal,tcoal,fracliq) tcoal = tcoal - t00 coalliq = rcoal * fracliq diff --git a/BRAMS/src/micro/mic_driv.f90 b/BRAMS/src/micro/mic_driv.f90 index a627b6128..ce593fba1 100644 --- a/BRAMS/src/micro/mic_driv.f90 +++ b/BRAMS/src/micro/mic_driv.f90 @@ -352,44 +352,48 @@ end subroutine mcphys_main !==========================================================================================! subroutine copyback(m1,i,j,pp,pi0,thp,btheta,rtp,rv,micro) - use mem_micro, only: & - micro_vars ! ! INTENT(IN) ! Only a type structure - - use micphys, only: & - k1 & ! intent(in) - ,k2 & ! intent(in) - ,k3 & ! intent(in) - ,lpw & ! intent(in) - ,ncat & ! intent(in) - ,jnmb & ! intent(in) - ,availcat & ! intent(in) - ,progncat & ! intent(in) - ,rx & ! intent(in) - ,cx & ! intent(in) - ,qx & ! intent(in) - ,pottemp & ! intent(in) - ,thil & ! intent(in) - ,rvap & ! intent(in) - ,rtot & ! intent(in) - ,accpx & ! intent(in) - ,pcprx ! ! intent(in) - - use mem_scratch, only : & - vctr11 ! ! intent(out) - - use rconstants, only: t00,cliq,cice,alli,p00,cpi,cpor - use therm_lib , only: qtk - use node_mod , only: mynum + use mem_micro, only : micro_vars ! ! intent(in) ! structure + use micphys , only : k1 & ! intent(in) + , k2 & ! intent(in) + , k3 & ! intent(in) + , lpw & ! intent(in) + , ncat & ! intent(in) + , jnmb & ! intent(in) + , availcat & ! intent(in) + , progncat & ! intent(in) + , rx & ! intent(in) + , cx & ! intent(in) + , qx & ! intent(in) + , pottemp & ! intent(in) + , thil & ! intent(in) + , rvap & ! intent(in) + , rtot & ! intent(in) + , accpx & ! intent(in) + , pcprx ! ! intent(in) + use therm_lib, only : exner2press & ! function + , extheta2temp ! ! function + use node_mod , only : mynum ! ! intent(in) implicit none !----- Arguments: ----------------------------------------------------------------------! - integer , intent(in) :: m1,i,j - real , dimension(m1), intent(inout) :: pp,pi0,thp,rtp,rv,btheta + integer , intent(in) :: m1 + integer , intent(in) :: i + integer , intent(in) :: j + real , dimension(m1), intent(inout) :: pp + real , dimension(m1), intent(inout) :: pi0 + real , dimension(m1), intent(inout) :: thp + real , dimension(m1), intent(inout) :: rtp + real , dimension(m1), intent(inout) :: rv + real , dimension(m1), intent(inout) :: btheta type (micro_vars) , intent(inout) :: micro !----- Local variables -----------------------------------------------------------------! - integer :: k,lcat - real :: tcoal, fracliq - real :: exner, pres, temp + integer :: k + integer :: lcat + real :: tcoal + real :: fracliq + real :: exner + real :: pres + real :: temp !---------------------------------------------------------------------------------------! @@ -492,8 +496,8 @@ subroutine copyback(m1,i,j,pp,pi0,thp,btheta,rtp,rv,micro) if (rv(k) > rtp(k) .or. any(rx(k,:) < 0)) then exner = pi0(k) + pp(k) - pres = p00 * (cpi * exner) ** cpor - temp = cpi * btheta(k) * exner + pres = exner2press(exner) + temp = extheta2temp(exner,btheta(k)) write (unit=*,fmt='(a)') '------ MODEL THERMODYNAMIC IS NON-SENSE... ------' write (unit=*,fmt='(a,1x,i5,a)' ) 'In node ',mynum,'...' write (unit=*,fmt='(a,1x,i5)' ) 'I =',i diff --git a/BRAMS/src/micro/mic_init.f90 b/BRAMS/src/micro/mic_init.f90 index 7ac3921f6..963a7b048 100644 --- a/BRAMS/src/micro/mic_init.f90 +++ b/BRAMS/src/micro/mic_init.f90 @@ -301,24 +301,35 @@ end subroutine micro_master !------------------------------------------------------------------------------------------! subroutine initqin(n1,n2,n3,q2,q6,q7,pi0,pp,theta,dn0,cccnp,cifnp) - use micphys, only : & - exner, & ! intent(out) - tair, & ! intent(out) - icloud, & ! intent(in) - irain, & ! intent(in) - igraup, & ! intent(in) - ihail, & ! intent(in) - ipris ! intent(in) - use rconstants, only : cpi,t3ple,cliq,cice,alli !intent(in) - + use micphys , only : exner & ! intent(out) + , tair & ! intent(out) + , icloud & ! intent(in) + , irain & ! intent(in) + , igraup & ! intent(in) + , ihail & ! intent(in) + , ipris ! ! intent(in) + use therm_lib , only : extheta2temp & ! function + , tl2uint ! ! function + use rconstants, only : t3ple ! ! intent(in) implicit none !----- Arguments -----------------------------------------------------------------------! - integer, intent(in) :: n1,n2,n3 - real, dimension(n1,n2,n3), intent(inout) :: q2, q6, q7, cifnp, cccnp - real, dimension(n1,n2,n3), intent(in) :: pi0, pp, theta, dn0 + integer, intent(in) :: n1 + integer, intent(in) :: n2 + integer, intent(in) :: n3 + real, dimension(n1,n2,n3), intent(inout) :: q2 + real, dimension(n1,n2,n3), intent(inout) :: q6 + real, dimension(n1,n2,n3), intent(inout) :: q7 + real, dimension(n1,n2,n3), intent(inout) :: cifnp + real, dimension(n1,n2,n3), intent(inout) :: cccnp + real, dimension(n1,n2,n3), intent(in) :: pi0 + real, dimension(n1,n2,n3), intent(in) :: pp + real, dimension(n1,n2,n3), intent(in) :: theta + real, dimension(n1,n2,n3), intent(in) :: dn0 !----- Local Variables -----------------------------------------------------------------! - integer :: i,j,k + integer :: i + integer :: j + integer :: k !---------------------------------------------------------------------------------------! @@ -327,11 +338,11 @@ subroutine initqin(n1,n2,n3,q2,q6,q7,pi0,pp,theta,dn0,cccnp,cifnp) do i = 1,n2 do k = 1,n1 exner(k) = pi0(k,i,j) + pp(k,i,j) - tair(k) = theta(k,i,j) * exner(k) * cpi + tair(k) = extheta2temp(exner(k),theta(k,i,j)) - if (irain >= 1) q2(k,i,j) = 0. ! cliq*tair(k) + alli - if (igraup >= 1) q6(k,i,j) = 0. ! 0.5 * (cliq+cice)*min(t3ple,tair(k)) + 0.5*alli - if (ihail >= 1) q7(k,i,j) = 0. !0.5 * (cliq+cice)*min(t3ple,tair(k)) + 0.5*alli + if (irain >= 1) q2(k,i,j) = tl2uint(tair(k),1.0) + if (igraup >= 1) q6(k,i,j) = tl2uint(min(t3ple,tair(k)),0.5) + if (ihail >= 1) q7(k,i,j) = tl2uint(min(t3ple,tair(k)),0.5) !----- Making up something, but not sure about this one. ----------------------! if (icloud == 7) cccnp(k,i,j) = 6.66e9 if (ipris == 7) cifnp(k,i,j) = 1.e5 * dn0(k,i,j) ** 5.4 diff --git a/BRAMS/src/micro/mic_misc.f90 b/BRAMS/src/micro/mic_misc.f90 index fa7321978..230086fa6 100644 --- a/BRAMS/src/micro/mic_misc.f90 +++ b/BRAMS/src/micro/mic_misc.f90 @@ -24,30 +24,27 @@ subroutine each_call(m1,dtlt) ! should not coallesce. ! !---------------------------------------------------------------------------------------! - use rconstants, only : & - pi4 & ! intent(in) - ,alvl & ! intent(in) - ,alvi & ! intent(in) - ,alli & ! intent(in) - ,cliq & ! intent(in) - ,cice & ! intent(in) - ,tsupercool ! ! intent(in) - - use micphys, only : & - jnmb & ! intent(in) - ,cfmas & ! intent(in) - ,parm & ! intent(in) - ,pwmas & ! intent(in) - ,emb & ! intent(out) - ,colf & ! intent(out) - ,pi4dt & ! intent(out) - ,sl & ! intent(out) - ,sc & ! intent(out) - ,sj & ! intent(out) - ,jhcat & ! intent(out) - ,sh & ! intent(out) - ,sm & ! intent(out) - ,sq ! ! intent(out) + use rconstants, only : pi4 & ! intent(in) + , cliq & ! intent(in) + , cice & ! intent(in) + , tsupercool_liq & ! intent(in) + , alvl3 & ! intent(in) + , alvi3 & ! intent(in) + , dcpvl & ! intent(in) + , dcpvi ! ! intent(in) + use micphys , only : jnmb & ! intent(in) + , cfmas & ! intent(in) + , parm & ! intent(in) + , pwmas & ! intent(in) + , emb & ! intent(out) + , colf & ! intent(out) + , pi4dt & ! intent(out) + , sc & ! intent(out) + , sj & ! intent(out) + , jhcat & ! intent(out) + , sh & ! intent(out) + , sm & ! intent(out) + , sq ! ! intent(out) implicit none @@ -55,7 +52,9 @@ subroutine each_call(m1,dtlt) integer, intent(in) :: m1 real , intent(in) :: dtlt !----- Local Variables -----------------------------------------------------------------! - integer :: lcat, lhcat, k + integer :: lcat + integer :: lhcat + integer :: k !---------------------------------------------------------------------------------------! @@ -63,8 +62,6 @@ subroutine each_call(m1,dtlt) colf = .785 * dtlt pi4dt = pi4 * dtlt - sl(1) = alvl - sl(2) = alvi sc(1) = cliq sc(2) = cice sj(1) = 0 @@ -74,7 +71,7 @@ subroutine each_call(m1,dtlt) sj(5) = 0 sj(6) = 1 sj(7) = 1 - sq(1) = tsupercool + sq(1) = tsupercool_liq sq(2) = 0. do lcat = 1,7 @@ -112,66 +109,90 @@ end subroutine each_call !==========================================================================================! subroutine fill_thermovars(m1,i,j,flpw,thp,btheta,pp,rtp,rv,wp,dn0,pi0,micro) - use mem_micro, only : micro_vars ! INTENT(IN) - micro structure - - use micphys, only : & - ncat & ! intent(in) - ,availcat & ! intent(in) - ,progncat & ! intent(in) - ,jnmb & ! intent(in) - ,rxmin & ! intent(in) - ,cxmin & ! intent(in) - ,jhcat & ! intent(in) - ,k1 & ! intent(out) - ,k2 & ! intent(out) - ,k3 & ! intent(out) - ,lpw & ! intent(out) - ,rx & ! intent(out) - ,cx & ! intent(out) - ,qr & ! intent(out) - ,qx & ! intent(out) - ,sa & ! intent(out) - ,thil & ! intent(out) - ,pottemp & ! intent(out) - ,til & ! intent(out) - ,theiv & ! intent(out) - ,rvstr & ! intent(out) - ,tair & ! intent(out) - ,tairstr & ! intent(out) - ,pottemp & ! intent(out) - ,qhydm & ! intent(out) - ,press & ! intent(out) - ,exner & ! intent(out) - ,vertvelo & ! intent(out) - ,rhoa & ! intent(out) - ,rhoi & ! intent(out) - ,rvap & ! intent(out) - ,rtot & ! intent(out) - ,rliq & ! intent(out) - ,rice & ! intent(out) - ,totcond & ! intent(out) - ,vap & ! intent(out) - ,tx & ! intent(out) - ,emb & ! intent(out) - ,rxfer & ! intent(out) - ,qrxfer & ! intent(out) - ,enxfer & ! intent(out) - ,cccnx & ! intent(out) - ,cifnx ! ! intent(out) - - use rconstants, only : p00, cpi, cp, cpor,alvi,alvl, tsupercool, cliqi - use therm_lib , only : qtk,thil2temp,dtempdrs,thetaeiv + use mem_micro , only : micro_vars ! ! intent(in) - micro structure + use micphys , only : ncat & ! intent(in) + , availcat & ! intent(in) + , progncat & ! intent(in) + , jnmb & ! intent(in) + , rxmin & ! intent(in) + , cxmin & ! intent(in) + , jhcat & ! intent(in) + , k1 & ! intent(out) + , k2 & ! intent(out) + , k3 & ! intent(out) + , lpw & ! intent(out) + , rx & ! intent(out) + , cx & ! intent(out) + , qr & ! intent(out) + , qx & ! intent(out) + , sa1 & ! intent(out) + , thil & ! intent(out) + , pottemp & ! intent(out) + , til & ! intent(out) + , theiv & ! intent(out) + , rvstr & ! intent(out) + , tair & ! intent(out) + , tairstr & ! intent(out) + , pottemp & ! intent(out) + , press & ! intent(out) + , exner & ! intent(out) + , vertvelo & ! intent(out) + , rhoa & ! intent(out) + , rhoi & ! intent(out) + , rvap & ! intent(out) + , rtot & ! intent(out) + , rliq & ! intent(out) + , rice & ! intent(out) + , totcond & ! intent(out) + , vap & ! intent(out) + , tx & ! intent(out) + , lx & ! intent(out) + , emb & ! intent(out) + , rxfer & ! intent(out) + , qrxfer & ! intent(out) + , enxfer & ! intent(out) + , cccnx & ! intent(out) + , cifnx ! ! intent(out) + use rconstants, only : alvi3 & ! intent(in) + , alvl3 & ! intent(in) + , tsupercool_liq & ! intent(in) + , cliqi ! ! intent(in) + use therm_lib , only : uint2tl & ! function + , thil2temp & ! function + , dtempdrs & ! function + , thetaeiv & ! function + , alvl & ! function + , alvi & ! function + , exner2press & ! function + , extemp2theta & ! function + , extheta2temp ! ! function implicit none !----- Arguments -----------------------------------------------------------------------! - integer , intent(in ) :: m1, i, j + integer , intent(in ) :: m1 + integer , intent(in ) :: i + integer , intent(in ) :: j real , intent(in ) :: flpw - real , dimension(m1), intent(in ) :: thp,btheta,pp,rtp,rv,wp,dn0,pi0 + real , dimension(m1), intent(in ) :: thp + real , dimension(m1), intent(in ) :: btheta + real , dimension(m1), intent(in ) :: pp + real , dimension(m1), intent(in ) :: rtp + real , dimension(m1), intent(in ) :: rv + real , dimension(m1), intent(in ) :: wp + real , dimension(m1), intent(in ) :: dn0 + real , dimension(m1), intent(in ) :: pi0 type (micro_vars) , intent(in ) :: micro !----- Local Variables -----------------------------------------------------------------! - integer :: k, lcatt, lcat, jcat,lhcat - real :: rhomin, frac, tcoal, fracliq + integer :: k + integer :: lcatt + integer :: lcat + integer :: jcat + integer :: lhcat + real :: rhomin + real :: frac + real :: tcoal + real :: fracliq !---------------------------------------------------------------------------------------! !----- Finding the lowest level above ground -------------------------------------------! @@ -181,7 +202,7 @@ subroutine fill_thermovars(m1,i,j,flpw,thp,btheta,pp,rtp,rv,wp,dn0,pi0,micro) do k=1,m1 thil (k) = thp (k) exner (k) = pi0 (k) + pp (k) - press (k) = p00 * (cpi * exner(k))**cpor + press (k) = exner2press(exner(k)) vertvelo (k) = wp (k) rhoa (k) = dn0 (k) rhoi (k) = 1./ rhoa(k) @@ -197,6 +218,8 @@ subroutine fill_thermovars(m1,i,j,flpw,thp,btheta,pp,rtp,rv,wp,dn0,pi0,micro) cx(k,lcat) = 0. qr(k,lcat) = 0. qx(k,lcat) = 0. + tx(k,lcat) = 0. + lx(k,lcat) = 0. vap(k,lcat) = 0. end do @@ -252,7 +275,9 @@ subroutine fill_thermovars(m1,i,j,flpw,thp,btheta,pp,rtp,rv,wp,dn0,pi0,micro) rx(k,2) = micro%rrp(k,i,j) rliq(k) = rliq(k) + rx(k,2) qx(k,2) = micro%q2(k,i,j) - tx(k,2) = tsupercool + cliqi * qx(k,2) + !---- Rain has to be in liquid phase even if it is supercooled. ---------------! + tx(k,2) = tsupercool_liq + cliqi * qx(k,2) + lx(k,2) = alvl(tx(k,2)) qr(k,2) = qx(k,2) * rx(k,2) if (progncat(2)) cx(k,2) = micro%crp(k,i,j) else @@ -327,7 +352,8 @@ subroutine fill_thermovars(m1,i,j,flpw,thp,btheta,pp,rtp,rv,wp,dn0,pi0,micro) k2(6) = k rx(k,6) = micro%rgp(k,i,j) qx(k,6) = micro%q6(k,i,j) - call qtk(qx(k,6),tx(k,6),fracliq) + call uint2tl(qx(k,6),tx(k,6),fracliq) + lx(k,6) = alvl(tx(k,6)) * fracliq + alvi(tx(k,6)) * (1.0 - fracliq) rliq(k) = rliq(k) + rx(k,6)*fracliq rice(k) = rice(k) + rx(k,6)*(1.-fracliq) qr(k,6) = qx(k,6) * rx(k,6) @@ -349,7 +375,8 @@ subroutine fill_thermovars(m1,i,j,flpw,thp,btheta,pp,rtp,rv,wp,dn0,pi0,micro) k2(7) = k rx(k,7) = micro%rhp(k,i,j) qx(k,7) = micro%q7(k,i,j) - call qtk(qx(k,7),tx(k,7),fracliq) + call uint2tl(qx(k,7),tx(k,7),fracliq) + lx(k,7) = alvl(tx(k,7)) * fracliq + alvi(tx(k,7)) * (1.0 - fracliq) rliq(k) = rliq(k) + rx(k,7)*fracliq rice(k) = rice(k) + rx(k,7)*(1.-fracliq) qr(k,7) = qx(k,7) * rx(k,7) @@ -379,18 +406,17 @@ subroutine fill_thermovars(m1,i,j,flpw,thp,btheta,pp,rtp,rv,wp,dn0,pi0,micro) ! which will be used to update thil after precipitation (sedimentation) takes place. ! !---------------------------------------------------------------------------------------! do k=1,m1 - til(k) = thil(k) * exner(k) * cpi + til(k) = extheta2temp(exner(k),thil(k)) totcond(k) = rliq(k) + rice(k) rvap(k) = rtot(k)-totcond(k) rvstr(k) = rvap(k) - qhydm(k) = alvl*rliq(k) + alvi *rice(k) !----- 1st guess for temperature, then temperature from theta-il and condensates. ---! - tcoal = btheta(k) * exner(k) * cpi + tcoal = extheta2temp(exner(k),btheta(k)) tair(k) = thil2temp(thil(k),exner(k),press(k),rliq(k),rice(k),tcoal) tairstr(k) = tair(k) - pottemp(k) = cp * tair(k) / exner(k) + pottemp(k) = extemp2theta(exner(k),tair(k)) !----- The A1 term in Walko et al. (2000) according to the new thermodynamics. ------! - sa(k,1) = (-1) * dtempdrs(exner(k),thil(k),tairstr(k),rliq(k),rice(k),1.e-12) + sa1(k) = (-1.) * dtempdrs(exner(k),thil(k),tairstr(k),rliq(k),rice(k),1.e-12) !------------------------------------------------------------------------------------! ! Ice-vapour equivalent potential temperature. This variable is conserved even ! @@ -398,34 +424,67 @@ subroutine fill_thermovars(m1,i,j,flpw,thp,btheta,pp,rtp,rv,wp,dn0,pi0,micro) ! compute the new theta-il (ice-liquid potential temperature) in the end of this ! ! subroutine. ! !------------------------------------------------------------------------------------! - theiv(k) = thetaeiv(thil(k),press(k),tair(k),rvap(k),rtot(k),4,.true.) + theiv(k) = thetaeiv(thil(k),press(k),tair(k),rvap(k),rtot(k),.true.) end do !---------------------------------------------------------------------------------------! ! Initialise temperature for cloud and pristine ice, because they can nucleate and ! - ! that will require an initial temperature. Snow and aggregates would not need this ! - ! in principle, but we will play it safe anyway. For rain, graupel, and hail, we use ! - ! their actual temperature if they already exist, otherwise assume environment ! - ! temperature. Again, this is probably unecessary but we are just trying to play it ! - ! safe. ! + ! that will require an initial temperature. Snow and aggregates also need to be ! + ! assigned a temperature so their latent heat can be corrected for temperature. For ! + ! rain, graupel, and hail, we use their actual temperature if they already exist, ! + ! otherwise assume environment temperature. ! !---------------------------------------------------------------------------------------! do lcat=1,7 select case (lcat) - case (1,3,4,5) - !----- Hydrometeors with no known temperature. Assume tair. ----------------------! + case (1) + !---------------------------------------------------------------------------------! + ! Cloud droplets. These are small, liquid-only hydrometeors, fill in with ! + ! air temperature and assign latent heat as liquid-only. ! + !---------------------------------------------------------------------------------! + do k=1,m1 + tx(k,lcat) = tair(k) + lx(k,lcat) = alvl(tx(k,lcat)) + end do + !---------------------------------------------------------------------------------! + + case (2) + !---------------------------------------------------------------------------------! + ! Rain drops. Levels which already had rain drops were already filled in, ! + ! here we just complete the other levels. Because rain-drops are liquid-only ! + ! hydrometeors, set latent heat accordingly. ! + !---------------------------------------------------------------------------------! + do k=1,m1 + if (rx(k,lcat) < rxmin(lcat)) then + tx(k,lcat) = tair(k) + lx(k,lcat) = alvl(tx(k,lcat)) + end if + end do + !---------------------------------------------------------------------------------! + + case(3,4,5) + !---------------------------------------------------------------------------------! + ! Pristine ice, snow flakes, or aggregates. These are small, ice-only ! + ! hydrometeors, fill in with air temperature and assign latent heat as ice-only. ! + !---------------------------------------------------------------------------------! do k=1,m1 tx(k,lcat) = tair(k) + lx(k,lcat) = alvi(tx(k,lcat)) end do - case (2,6,7) !---------------------------------------------------------------------------------! - ! The levels with hydrometeors were already initialised using the internal ! - ! energy. Therefore we only to fill the other levels with tair. ! + case (6,7) + !---------------------------------------------------------------------------------! + ! Graupel and hail. The levels with hydrometeors were already initialised ! + ! using the internal energy. Therefore we only to fill the other levels with ! + ! tair. Although graupel and hail are mixed phase, we initialise latent heat ! + ! with ice thermodynamics. ! !---------------------------------------------------------------------------------! do k=1,m1 if (rx(k,lcat) < rxmin(lcat)) then tx(k,lcat) = tair(k) + lx(k,lcat) = 0.5 * (alvi(tx(k,lcat)) + alvl(tx(k,lcat))) end if end do + !---------------------------------------------------------------------------------! end select end do @@ -463,10 +522,10 @@ subroutine update_thermo(m1) , thil & ! intent(out) , pottemp & ! intent(out) , tair ! ! intent(out) - use therm_lib , only : qtk & ! subroutine + use therm_lib , only : uint2tl & ! subroutine , thetaeiv2thil & ! function - , thil2temp ! ! function - use rconstants , only : cp ! ! intent(in) + , thil2temp & ! function + , extemp2theta ! ! function !----- Argument ------------------------------------------------------------------------! integer, intent(in) :: m1 !----- Local variables -----------------------------------------------------------------! @@ -505,7 +564,7 @@ subroutine update_thermo(m1) do lcat=6,7 do k = lpw,m1 if (rx(k,lcat) > rxmin(lcat)) then - call qtk(qx(k,lcat),tcoal,fracliq) + call uint2tl(qx(k,lcat),tcoal,fracliq) rliq(k) = rliq(k) + rx(k,lcat)*fracliq rice(k) = rice(k) + rx(k,lcat)*(1.-fracliq) end if @@ -526,7 +585,7 @@ subroutine update_thermo(m1) do k = lpw,m1 thil(k) = thetaeiv2thil(theiv(k),press(k),rtot(k),.true.) tair(k) = thil2temp(thil(k),exner(k),press(k),rliq(k),rice(k),tair(k)) - pottemp(k) = cp * tair(k) / exner(k) + pottemp(k) = extemp2theta(exner(k),tair(k)) end do return @@ -543,80 +602,81 @@ end subroutine update_thermo !==========================================================================================! subroutine each_column(m1,dtlt) - use rconstants, only : & - pi4 & ! intent(in) - ,t3ple & ! intent(in) - ,es3ple & ! intent(in) - ,t00 & ! intent(in) - ,ep & ! intent(in) - ,epes3ple & ! intent(in) - ,alvl & ! intent(in) - ,alvi ! intent(in) - - use micphys, only : & - k1 & ! intent(in) - ,k2 & ! intent(in) - ,lpw & ! intent(in) - ,press & ! intent(in) - ,tair & ! intent(in) - ,jhabtab & ! intent(in) - ,colf & ! intent(in) - ,tairstr & ! intent(in) - ,rvstr & ! intent(in) - ,rxmin & ! intent(in) - ,rvap & ! intent(in) - ,rvlsair & ! intent(out) - ,rvisair & ! intent(out) - ,rhoa & ! intent(in) - ,rhoi & ! intent(in) - ,press & ! intent(in) - ,colf & ! intent(out) - ,pi4dt & ! intent(out) - ,tairc & ! intent(out) - ,thrmcon & ! intent(out) - ,dynvisc & ! intent(out) - ,jhcat & ! intent(out) - ,vapdif & ! intent(out) - ,rdynvsci & ! intent(out) - ,denfac & ! intent(out) - ,colfacr & ! intent(out) - ,colfacr2 & ! intent(out) - ,colfacc & ! intent(out) - ,colfacc2 & ! intent(out) - ,tref & ! intent(out) - ,sa & ! intent(out) - ,sumuy & ! intent(out) - ,sumuz & ! intent(out) - ,sumvr & ! intent(out) - ,rvsref & ! intent(out) - ,rvsrefp & ! intent(out) - ,sh ! ! intent(out) - - - use micro_coms, only : & - ckcoeff & ! intent(in) - ,dvcoeff & ! intent(in) - ,vdcoeff & ! intent(in) - ,dtempmax ! ! intent(in) - - use therm_lib , only : & - rslf & ! Function - ,rsif & ! Function - ,rslfp & ! Function - ,rsifp & ! Function - ,rehuil ! ! Function - - - - + use rconstants , only : pi4 & ! intent(in) + , t3ple & ! intent(in) + , es3ple & ! intent(in) + , t00 & ! intent(in) + , ep & ! intent(in) + , epes3ple ! ! intent(in) + use micphys , only : ncat & ! intent(in) + , k1 & ! intent(in) + , k2 & ! intent(in) + , lpw & ! intent(in) + , press & ! intent(in) + , tair & ! intent(in) + , jhabtab & ! intent(in) + , colf & ! intent(in) + , tairstr & ! intent(in) + , rvstr & ! intent(in) + , rxmin & ! intent(in) + , rvap & ! intent(in) + , lx & ! intent(in) + , rvlsair & ! intent(out) + , rvisair & ! intent(out) + , rhoa & ! intent(in) + , rhoi & ! intent(in) + , press & ! intent(in) + , sa1 & ! intent(out) + , colf & ! intent(out) + , pi4dt & ! intent(out) + , tairc & ! intent(out) + , thrmcon & ! intent(out) + , dynvisc & ! intent(out) + , jhcat & ! intent(out) + , vapdif & ! intent(out) + , rdynvsci & ! intent(out) + , denfac & ! intent(out) + , colfacr & ! intent(out) + , colfacr2 & ! intent(out) + , colfacc & ! intent(out) + , colfacc2 & ! intent(out) + , tref & ! intent(out) + , sa2 & ! intent(out) + , sa3 & ! intent(out) + , sa4 & ! intent(out) + , sa6 & ! intent(out) + , sa8 & ! intent(out) + , sumuy & ! intent(out) + , sumuz & ! intent(out) + , sumvr & ! intent(out) + , rvsref & ! intent(out) + , rvsrefp & ! intent(out) + , sh ! ! intent(out) + use micro_coms, only : ckcoeff & ! intent(in) + , dvcoeff & ! intent(in) + , vdcoeff & ! intent(in) + , dtempmax ! ! intent(in) + use therm_lib , only : rslf & ! function + , rsif & ! function + , rslfp & ! function + , rsifp & ! function + , rehuil & ! function + , alvl & ! function + , alvi & ! function + , tl2uint & ! function + , uint2tl ! ! function implicit none !----- Arguments -----------------------------------------------------------------------! integer, intent(in) :: m1 real , intent(in) :: dtlt !----- Local Variables -----------------------------------------------------------------! - integer :: k,nt,ns,irh - real :: relhum,pvap - real :: tauxkelvin + integer :: k + integer :: nt + integer :: ns + integer :: irh + integer :: lcat + real :: relhum + real :: pvap !---------------------------------------------------------------------------------------! do k = lpw,m1-1 @@ -632,7 +692,7 @@ subroutine each_column(m1,dtlt) !----- Diagnose habit of pristine ice and snow --------------------------------------! nt = max(1,min(31,-nint(tairc(k)))) !----- THERMO DILEMMA : Shouldn't it be rehuil here? --------------------------------! - relhum = min(1.,rehuil(press(k),tair(k),rvap(k))) + relhum = min(1.,rehuil(press(k),tair(k),rvap(k),.false.)) irh = nint(100.*relhum) ns = max(1,irh) @@ -651,39 +711,71 @@ subroutine each_column(m1,dtlt) colfacc(k) = colfacr(k) * rhoa(k) colfacc2(k) = 2. * colfacc(k) - tref(k,1) = tair(k) - min(dtempmax,700. * (rvlsair(k) - rvap(k))) - sa(k,2) = thrmcon(k) * sa(k,1) - sa(k,3) = thrmcon(k) * (tairstr(k) + sa(k,1) * rvstr(k)) + tref(k,1) = tair(k) - min(dtempmax,700. * (rvlsair(k) - rvap(k))) + tref(k,2) = min(t3ple,tref(k,1)) + + + sa2(k) = thrmcon(k) * sa1(k) + sa3(k) = thrmcon(k) * (tairstr(k) + sa1(k) * rvstr(k)) sumuy(k) = 0. sumuz(k) = 0. sumvr(k) = 0. - end do - - !----- Liquid water properties ---------------------------------------------------------! - do k = k1(8),k2(8) + rvsref (k,1) = rslf(press(k),tref(k,1)) rvsrefp(k,1) = rslfp(press(k),tref(k,1)) - - sa(k,4) = rvsrefp(k,1) * tref(k,1) - rvsref(k,1) - sa(k,6) = alvl * rvsrefp(k,1) - sa(k,8) = alvl * sa(k,4) - enddo - !----- Ice properties ------------------------------------------------------------------! - do k = k1(9),k2(9) - tref(k,2) = min(t3ple,tref(k,1)) rvsref (k,2) = rsif(press(k),tref(k,2)) rvsrefp(k,2) = rsifp(press(k),tref(k,2)) - - sa(k,5) = rvsrefp(k,2) * tref(k,2) - rvsref(k,2) - sa(k,7) = alvi * rvsrefp(k,2) - sa(k,9) = alvi * sa(k,5) - sh(k,3) = 0. - sh(k,4) = 0. - sh(k,5) = 0. + end do + !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! + ! Loop over all categories, and within each category, we loop over all levels that ! + ! contain the hydrometeor. ! + !---------------------------------------------------------------------------------------! + do lcat=1,ncat + select case(lcat) + case (1:2) + !---------------------------------------------------------------------------------! + ! Cloud droplets and rain drop. These are liquid-only hydrometeors, so we ! + ! use the liquid phase thermodynamics. ! + !---------------------------------------------------------------------------------! + do k = k1(10),k2(10) + sa4(k,lcat) = rvsrefp(k,1) * tref(k,1) - rvsref(k,1) + sa6(k,lcat) = lx(k,lcat) * rvsrefp(k,1) + sa8(k,lcat) = lx(k,lcat) * sa4(k,lcat) + end do + !---------------------------------------------------------------------------------! + case (3:5) + !---------------------------------------------------------------------------------! + ! Pristine ice, snow flakes, and aggregates. These are ice-only hydro- ! + ! meteors, so we use ice phase thermodynamics. ! + !---------------------------------------------------------------------------------! + do k = k1(10),k2(10) + sa4(k,lcat) = rvsrefp(k,2) * tref(k,2) - rvsref(k,2) + sa6(k,lcat) = lx(k,lcat) * rvsrefp(k,2) + sa8(k,lcat) = lx(k,lcat) * sa4(k,lcat) + sh (k,lcat) = 0. + end do + !---------------------------------------------------------------------------------! + case (6:7) + !---------------------------------------------------------------------------------! + ! Graupel and hail. These are mixed phase hydrometeors, but we use the ice ! + ! values here. We, however, don't change the value of sh for them. ! + !---------------------------------------------------------------------------------! + do k = k1(10), k2(10) + sa4(k,lcat) = rvsrefp(k,2) * tref(k,2) - rvsref(k,2) + sa6(k,lcat) = lx(k,lcat) * rvsrefp(k,2) + sa8(k,lcat) = lx(k,lcat) * sa4(k,lcat) + end do + !---------------------------------------------------------------------------------! + end select + !------------------------------------------------------------------------------------! + end do + !---------------------------------------------------------------------------------------! return end subroutine each_column !==========================================================================================! @@ -805,46 +897,54 @@ end subroutine enemb !==========================================================================================! subroutine x02(lcat) - use rconstants, only: & - qicet3, & ! INTENT(IN) - qliqt3, & ! INTENT(IN) - alli ! INTENT(IN) - - use micphys, only: & - rx, & ! INTENT(INOUT) - rxmin, & ! intent(in) - jhcat, & ! INTENT(IN) - k1, & ! intent(in) - k2, & ! intent(in) - rhoa, & ! intent(in) - vterm, & ! INTENT(OUT) - vtfac, & ! INTENT(IN) - emb, & ! INTENT(IN) - pwvtmasi, & ! INTENT(IN) - denfac, & ! INTENT(IN) - qx, & ! INTENT(OUT) - qr, & ! INTENT(INOUT) - cx, & ! INTENT(INOUT) - enmlttab, & ! INTENT(IN) - dnfac, & ! INTENT(IN) - pwmasi, & ! INTENT(IN) - gnu, & ! INTENT(IN) - shedtab ! INTENT(IN) - - use therm_lib, only : qtk - - use micro_coms, only : & - qrainmin, & ! INTENT(IN) - qrainmax ! ! INTENT(IN) - + use rconstants, only : uiicet3 & ! intent(in) + , uiliqt3 ! ! intent(in) + use micphys , only : rx & ! intent(inout) + , rxmin & ! intent(in) + , jhcat & ! intent(in) + , k1 & ! intent(in) + , k2 & ! intent(in) + , rhoa & ! intent(in) + , vterm & ! intent(out) + , vtfac & ! intent(in) + , emb & ! intent(in) + , pwvtmasi & ! intent(in) + , denfac & ! intent(in) + , qx & ! intent(out) + , qr & ! intent(inout) + , cx & ! intent(inout) + , enmlttab & ! intent(in) + , dnfac & ! intent(in) + , pwmasi & ! intent(in) + , gnu & ! intent(in) + , shedtab ! ! intent(in) + use therm_lib , only : uint2tl ! ! sub-routine + use micro_coms, only : qrainmin & ! intent(in) + , qrainmax ! ! intent(in) implicit none - !----- Argument ------------------------------------------------------------------------! integer, intent(in) :: lcat !----- Local Variables -----------------------------------------------------------------! - integer :: k,jflag,lhcat,inc,idns - real :: rinv,closs,rxinv,rmelt,fracliq,cmelt,tcoal,ricetor6,rshed,rmltshed,qrmelt - real :: qrmltshed,shedmass,fracmloss,dn + integer :: k + integer :: jflag + integer :: lhcat + integer :: inc + integer :: idns + real :: rinv + real :: closs + real :: rxinv + real :: rmelt + real :: fracliq + real :: cmelt + real :: tcoal + real :: ricetor6 + real :: rshed + real :: rmltshed + real :: qrmelt + real :: qrmltshed + real :: shedmass + real :: fracmloss + real :: dn !---------------------------------------------------------------------------------------! k1(lcat) = k1(10) @@ -893,11 +993,11 @@ subroutine x02(lcat) rinv = 1. / rx(k,lcat) qx(k,lcat) = qr(k,lcat) * rinv - call qtk(qx(k,lcat),tcoal,fracliq) + call uint2tl(qx(k,lcat),tcoal,fracliq) rmelt = rx(k,lcat) * fracliq cmelt = cx(k,lcat) * fracliq - qrmelt = qliqt3 * rmelt + qrmelt = uiliqt3 * rmelt rx(k,lcat) = rx(k,lcat) - rmelt rx(k,1) = rx(k,1) + rmelt @@ -919,7 +1019,7 @@ subroutine x02(lcat) rinv = 1. / rx(k,lcat) qx(k,lcat) = qr(k,lcat) * rinv - call qtk(qx(k,lcat),tcoal,fracliq) + call uint2tl(qx(k,lcat),tcoal,fracliq) if (fracliq > 1.e-6) then rmelt = rx(k,lcat) * fracliq @@ -931,8 +1031,8 @@ subroutine x02(lcat) ricetor6 = min(rx(k,lcat) - rmelt,rmelt) rx(k,lcat) = rx(k,lcat) - rmelt - ricetor6 rx(k,6) = rx(k,6) + rmelt + ricetor6 - qr(k,6) = qr(k,6) + rmelt * qliqt3 + ricetor6 * qicet3 - qx(k,lcat) = qicet3 !---- All water is gone, leave ice at 0°C only ---------! + qr(k,6) = qr(k,6) + rmelt * uiliqt3 + ricetor6 * uiicet3 + qx(k,lcat) = uiicet3 !---- All water is gone, leave ice at 0°C only --------! qr(k,lcat) = qx(k,lcat) * rx(k,lcat) if (rx(k,6) > rxmin(6)) qx(k,6) = qr(k,6) / rx(k,6) @@ -950,11 +1050,11 @@ subroutine x02(lcat) if (rx(k,lcat) >= rxmin(lcat)) then rxinv = 1. / rx(k,lcat) qx(k,lcat) = qr(k,lcat) * rxinv - call qtk(qx(k,lcat),tcoal,fracliq) + call uint2tl(qx(k,lcat),tcoal,fracliq) if (fracliq > 0.95) then rx(k,2) = rx(k,2) + rx(k,6) - qr(k,2) = qr(k,2) + rx(k,6) * qliqt3 + qr(k,2) = qr(k,2) + rx(k,6) * uiliqt3 cx(k,2) = cx(k,2) + cx(k,6) qx(k,2) = qr(k,2) / rx(k,2) rx(k,6) = 0. @@ -971,11 +1071,11 @@ subroutine x02(lcat) if (rx(k,lcat) >= rxmin(lcat)) then rxinv = 1. / rx(k,lcat) qx(k,lcat) = qr(k,lcat) * rxinv - call qtk(qx(k,lcat),tcoal,fracliq) + call uint2tl(qx(k,lcat),tcoal,fracliq) if (fracliq > 0.95) then rx(k,2) = rx(k,2) + rx(k,7) - qr(k,2) = qr(k,2) + rx(k,7) * qliqt3 + qr(k,2) = qr(k,2) + rx(k,7) * uiliqt3 cx(k,2) = cx(k,2) + cx(k,7) qx(k,2) = qr(k,2) / rx(k,2) rx(k,7) = 0. @@ -991,7 +1091,7 @@ subroutine x02(lcat) idns = max(1,nint(1.e3 * dn * gnu(lcat))) rshed = rx(k,lcat) * shedtab(inc,idns) rmltshed = rshed - qrmltshed = rmltshed * qliqt3 + qrmltshed = rmltshed * uiliqt3 rx(k,2) = rx(k,2) + rmltshed qr(k,2) = qr(k,2) + qrmltshed @@ -1067,8 +1167,6 @@ end subroutine pc03 !==========================================================================================! !==========================================================================================! subroutine sedim(m1,lcat,if_adap,mynum,pcpg,qpcpg,dpcpg,dtlti,pcpfillc,pcpfillr,sfcpcp,dzt) - - use rconstants, only : cpi,ttripoli,alvl,alvi,alli,cp ! intent(in) use micphys , only : & k1 & ! intent(in ) ,k2 & ! intent(in ) @@ -1110,16 +1208,37 @@ subroutine sedim(m1,lcat,if_adap,mynum,pcpg,qpcpg,dpcpg,dtlti,pcpfillc,pcpfillr, implicit none !----- Arguments -----------------------------------------------------------------------! - integer , intent(in) :: m1,lcat,if_adap,mynum + integer , intent(in) :: m1 + integer , intent(in) :: lcat + integer , intent(in) :: if_adap + integer , intent(in) :: mynum real , intent(in) :: dtlti real, dimension(m1 ), intent(in) :: dzt - real, dimension(m1,maxkfall,nembfall,nhcat), intent(in) :: pcpfillc, pcpfillr + real, dimension(m1,maxkfall,nembfall,nhcat), intent(in) :: pcpfillc + real, dimension(m1,maxkfall,nembfall,nhcat), intent(in) :: pcpfillr real, dimension( maxkfall,nembfall,nhcat), intent(in) :: sfcpcp - real , intent(inout) :: pcpg, qpcpg, dpcpg + real , intent(inout) :: pcpg + real , intent(inout) :: qpcpg + real , intent(inout) :: dpcpg !----- Local Variables -----------------------------------------------------------------! - integer :: k,lhcat,iemb,iemb2,kkf,kk,jcat,ee - real :: dispemb,riemb,wt2,psfc - real :: tcoal,fracliq,dqlat,coldrhoa,roldrhoa,qroldrhoa + integer :: k + integer :: lhcat + integer :: iemb + integer :: iemb2 + integer :: kkf + integer :: kk + integer :: jcat + integer :: ee + real :: dispemb + real :: riemb + real :: wt2 + real :: psfc + real :: tcoal + real :: fracliq + real :: dqlat + real :: coldrhoa + real :: roldrhoa + real :: qroldrhoa !---------------------------------------------------------------------------------------! !----- Zero out any "fall" cells that might accumulate precipitation -------------------! @@ -1149,9 +1268,8 @@ subroutine sedim(m1,lcat,if_adap,mynum,pcpg,qpcpg,dpcpg,dtlti,pcpfillc,pcpfillr, do kkf = 1,min(maxkfall,k-1) kk = k + 1 - kkf - - cfall(kk) = cfall(kk) + coldrhoa * rhoi(kk) * pcpfillc(k,kkf,iemb,lhcat) - rfall(kk) = rfall(kk) + roldrhoa * rhoi(kk) * pcpfillr(k,kkf,iemb,lhcat) + cfall (kk) = cfall (kk) + coldrhoa * rhoi(kk) * pcpfillc(k,kkf,iemb,lhcat) + rfall (kk) = rfall (kk) + roldrhoa * rhoi(kk) * pcpfillr(k,kkf,iemb,lhcat) qrfall(kk) = qrfall(kk) + qroldrhoa * rhoi(kk) * pcpfillr(k,kkf,iemb,lhcat) end do @@ -1213,23 +1331,23 @@ end subroutine sedim !------------------------------------------------------------------------------------------! subroutine negadj1(m1,m2,m3,ia,iz,ja,jz) - use mem_basic , only: & - basic_g ! intent(out) - - use mem_micro , only : & - micro_g ! ! intent(out) - - use mem_grid , only : & - grid_g & ! intent(in) - ,ngrid ! ! intent(in) - - use therm_lib , only : & - vapour_on ! ! intent(in) + use mem_basic , only : basic_g ! intent(out) + use mem_micro , only : micro_g ! ! intent(out) + use mem_grid , only : grid_g & ! intent(in) + , ngrid ! ! intent(in) + use therm_lib , only : vapour_on ! ! intent(in) implicit none !----- Arguments -----------------------------------------------------------------------! - integer, intent(in) :: m1,m2,m3,ia,iz,ja,jz + integer, intent(in) :: m1 + integer, intent(in) :: m2 + integer, intent(in) :: m3 + integer, intent(in) :: ia + integer, intent(in) :: iz + integer, intent(in) :: ja + integer, intent(in) :: jz + !---------------------------------------------------------------------------------------! if (.not. vapour_on) return diff --git a/BRAMS/src/micro/mic_nuc.f90 b/BRAMS/src/micro/mic_nuc.f90 index d638e317f..58335aa51 100644 --- a/BRAMS/src/micro/mic_nuc.f90 +++ b/BRAMS/src/micro/mic_nuc.f90 @@ -232,7 +232,7 @@ subroutine icenuc(m1,ngr,dtlt) k2pnuc = 1 do k = lpw,m1-1 - rhhz = rehuil(press(k),tair(k),rvap(k)) + rhhz = rehuil(press(k),tair(k),rvap(k),.false.) haznuc = 0. if (rhhz > 0.82 .and. tairc(k) <= -35.01) then rirhhz = min(0.1799,rhhz-0.82) / drhhz + 1.0 @@ -258,7 +258,7 @@ subroutine icenuc(m1,ngr,dtlt) ! Heterogeneous nucleation by deposition condensation freezing with deposition ! ! nuclei. In 4.3 and beyond, assume that it gives #/kg. ! !------------------------------------------------------------------------------------! - ssi = min(ssi0,rehui(press(k),tair(k),rvap(k)) - 1.) + ssi = min(ssi0,rehui(press(k),tair(k),rvap(k),.false.) - 1.) if (ssi > 0. .and. tairc(k) <= -5.) then fracifn = exp(12.96 * (ssi - ssi0)) else diff --git a/BRAMS/src/micro/mic_vap.f90 b/BRAMS/src/micro/mic_vap.f90 index ac2c42bef..a5637da7a 100644 --- a/BRAMS/src/micro/mic_vap.f90 +++ b/BRAMS/src/micro/mic_vap.f90 @@ -25,22 +25,19 @@ subroutine diffprep(lcat) !----- Arguments -----------------------------------------------------------------------! integer, intent(in) :: lcat !----- Local variables -----------------------------------------------------------------! - integer :: k,if1,if4,if6,if8,lhcat - real :: fre,scdei + integer :: k + integer :: if1 + integer :: lhcat + real :: fre + real :: scdei !---------------------------------------------------------------------------------------! !----- Selecting whether to use liquid or ice related stuff ----------------------------! select case (lcat) case (1,2) if1 = 1 - if4 = 4 - if6 = 6 - if8 = 8 case default if1 = 2 - if4 = 5 - if6 = 7 - if8 = 9 end select !---------------------------------------------------------------------------------------! @@ -53,15 +50,15 @@ subroutine diffprep(lcat) if (rx(k,lcat) < rxmin(lcat)) cycle mainloop - fre = frefac1(lhcat) * emb(k,lcat) ** pwmasi(lhcat) & - + rdynvsci(k) * frefac2(lhcat) * emb(k,lcat) ** cdp1(lhcat) + fre = frefac1(lhcat) * emb(k,lcat) ** pwmasi(lhcat) & + + rdynvsci(k) * frefac2(lhcat) * emb(k,lcat) ** cdp1(lhcat) sb(k,lcat) = cx(k,lcat) * rhoa(k) * fre * pi4dt su(k,lcat) = vapdif(k) * sb(k,lcat) sd(k,lcat) = sh(k,lcat) * rx(k,lcat) - se(k,lcat) = su(k,lcat) * sa(k,if6) + sb(k,lcat) * thrmcon(k) - sf(k,lcat) = su(k,lcat) * sl(if1) - sb(k,lcat) * sa(k,2) - sg(k,lcat) = su(k,lcat) * sa(k,if8) + sb(k,lcat) * sa(k,3) + sj(lcat) * qr(k,lcat) + se(k,lcat) = su(k,lcat) * sa6(k,lcat) + sb(k,lcat) * thrmcon(k) + sf(k,lcat) = su(k,lcat) * lx(k,lcat) - sb(k,lcat) * sa2(k) + sg(k,lcat) = su(k,lcat) * sa8(k,lcat) + sb(k,lcat) * sa3(k) + sj(lcat) * qr(k,lcat) scdei = 1. / (sc(if1) * sd(k,lcat) + se(k,lcat)) ss(k,lcat) = sf(k,lcat) * scdei @@ -71,7 +68,7 @@ subroutine diffprep(lcat) !---------------------------------------------------------------------------------------! - ! Iced categories. The first trial assumed Mj = 1 and assuming rvap to be the ! + ! Ice categories. The first trial assumed Mj = 1 and assuming rvap to be the ! ! previous rvap. If that gives T above the triple point, then force it to be at the ! ! triple point, and Mj becomes 0. Otherwise, happy with the temperature and Mj is set ! ! to 1. ! @@ -112,7 +109,7 @@ subroutine diffprep(lcat) lastloop: do k = k1(lcat),k2(lcat) if (rx(k,lcat) < rxmin(lcat)) cycle lastloop - sy(k,lcat) = rvsrefp(k,if1) * sm(k,lcat) * sw(k,lcat) - sa(k,if4) + sy(k,lcat) = rvsrefp(k,if1) * sm(k,lcat) * sw(k,lcat) - sa4(k,lcat) sz(k,lcat) = 1. - rvsrefp(k,if1) * ss(k,lcat) * sm(k,lcat) sumuy(k) = sumuy(k) + su(k,lcat) * sy(k,lcat) sumuz(k) = sumuz(k) + su(k,lcat) * sz(k,lcat) @@ -191,10 +188,8 @@ subroutine vapflux(lcat) select case (lcat) case (1:2) if1 = 1 - if4 = 4 case (3:7) if1 = 2 - if4 = 5 end select mainloop: do k = k1(lcat),k2(lcat) @@ -210,7 +205,7 @@ subroutine vapflux(lcat) else tx(k,lcat) = t3ple end if - vap(k,lcat) = su(k,lcat) * (rvap(k) + sa(k,if4) - rvsrefp(k,if1) * tx(k,lcat)) + vap(k,lcat) = su(k,lcat) * (rvap(k) + sa4(k,lcat) - rvsrefp(k,if1) * tx(k,lcat)) !------------------------------------------------------------------------------------! @@ -394,9 +389,23 @@ end subroutine psxfer !------------------------------------------------------------------------------------------! subroutine newtemp() - use rconstants - use micphys - use therm_lib, only: rslf,rsif + use rconstants, only : t00 ! ! intent(in) + use micphys , only : k1 & ! intent(in) + , k2 & ! intent(in) + , tairstr & ! intent(in) + , sa1 & ! intent(in) + , rvstr & ! intent(in) + , rvap & ! intent(in) + , exner & ! intent(in) + , press & ! intent(in) + , tair & ! intent(out) + , tairc & ! intent(out) + , pottemp & ! intent(out) + , rvlsair & ! intent(out) + , rvisair ! ! intent(out) + use therm_lib , only : rslf & ! function + , rsif & ! function + , extemp2theta ! ! function implicit none @@ -404,13 +413,14 @@ subroutine newtemp() integer :: k !---------------------------------------------------------------------------------------! + do k = k1(10),k2(10) - tair(k) = tairstr(k) + sa(k,1) * (rvstr(k) - rvap(k)) + tair(k) = tairstr(k) + sa1(k) * (rvstr(k) - rvap(k)) tairc(k) = tair(k) - t00 - pottemp(k) = tair(k) * cp / exner(k) + pottemp(k) = extemp2theta(exner(k),tair(k)) rvlsair(k) = rslf(press(k),tair(k)) - rvisair(k) = rsif (press(k),tair(k)) + rvisair(k) = rsif(press(k),tair(k)) end do return diff --git a/BRAMS/src/micro/micphys.f90 b/BRAMS/src/micro/micphys.f90 index 28cb017b3..88af1945d 100644 --- a/BRAMS/src/micro/micphys.f90 +++ b/BRAMS/src/micro/micphys.f90 @@ -101,18 +101,19 @@ module micphys real, dimension(nhcat) :: pwvtmasi,emb2,cxmin real, dimension(nzpmax) :: tair,tairc,tairstr,til,rvstr,press,exner - real, dimension(nzpmax) :: rhoa,rhoi,rtot,rvap,rliq,rice,qhydm + real, dimension(nzpmax) :: rhoa,rhoi,rtot,rvap,rliq,rice real, dimension(nzpmax) :: rvlsair,rvisair,thrmcon real, dimension(nzpmax) :: vapdif,dynvisc,rdynvsci,denfac,dn0i,colfacr real, dimension(nzpmax) :: colfacr2,colfacc,colfacc2,sumuy,sumuz,sumvr real, dimension(nzpmax) :: scrmic1,scrmic2,scrmic3,cccnx,cifnx real, dimension(nzpmax) :: dsed_thil,totcond,thil,pottemp,vertvelo,rloss real, dimension(nzpmax) :: enloss,rfall,cfall,qrfall,theiv - real, dimension(nzpmax,ncat) :: rx,cx,qr,qx,tx,emb,vterm,vap,ttest,wct1 + real, dimension(nzpmax,ncat) :: rx,cx,qr,qx,tx,lx,emb,vterm,vap,ttest,wct1 real, dimension(nzpmax,ncat) :: wct2,sb,sd,se,sf,sg,sh,sm,ss,su,sw,sy,sz real, dimension(nzpmax,2) :: tref,rvsref,rvsrefp - real, dimension(nzpmax,9) :: sa + real, dimension(nzpmax) :: sa1,sa2,sa3 + real, dimension(nzpmax,ncat) :: sa4,sa6,sa8 real, dimension(nzpmax,10) :: eff real, dimension(nzpmax,ncat,ncat) :: rxfer,qrxfer,enxfer @@ -130,7 +131,7 @@ module micphys real, dimension(ninc) :: rmlttab real, dimension(ninc,nhcat) :: enmlttab real, dimension(ninc,ndns) :: shedtab - real, dimension(2) :: sc,sl,sq + real, dimension(2) :: sc,sq real, dimension(7) :: sj,pcprx,accpx real, dimension(nd1cc) :: r1tabcc,c1tabcc,c2tabcc diff --git a/BRAMS/src/micro/micro_coms.f90 b/BRAMS/src/micro/micro_coms.f90 index 259f82703..05b21dabc 100644 --- a/BRAMS/src/micro/micro_coms.f90 +++ b/BRAMS/src/micro/micro_coms.f90 @@ -7,9 +7,15 @@ !==========================================================================================! module micro_coms - use rconstants, only : boltzmann,pi1,t00,cliq,alli,qicet3,tsupercool - use micphys , only : ncat,nhcat - + use rconstants, only : boltzmann & ! intent(in) + , pi1 & ! intent(in) + , t00 & ! intent(in) + , alli & ! intent(in) + , cliq & ! intent(in) + , tsupercool_liq & ! intent(in) + , uiicet3 ! ! intent(in) + use micphys , only : ncat & ! intent(in) + , nhcat ! ! intent(in) implicit none !----- Precipitation table structure ---------------------------------------------------! @@ -44,13 +50,13 @@ module micro_coms !---------------------------------------------------------------------------------------! !----- Minimum and maximum energy for rain ---------------------------------------------! - real, parameter :: qrainmin = cliq * (193.16 - tsupercool) ! Minimum -80°C - real, parameter :: qrainmax = cliq * (321.16 - tsupercool) ! Maximum 48°C + real, parameter :: qrainmin = cliq * (193.16 - tsupercool_liq) ! Minimum -80°C + real, parameter :: qrainmax = cliq * (321.16 - tsupercool_liq) ! Maximum 48°C !----- Minimum and maximum energy for mixed phases -------------------------------------! - real, parameter :: qmixedmin = qicet3-100000. ! Equivalent to former -100000 J/kg - real, parameter :: qmixedmax = qicet3+350000. ! Equivalent to former 350000 J/kg + real, parameter :: qmixedmin = uiicet3-100000. ! Equivalent to former -100000 J/kg + real, parameter :: qmixedmax = uiicet3+350000. ! Equivalent to former 350000 J/kg !----- Maximum energy for pristine ice before it completely disappears -----------------! - real, parameter :: qprismax = qicet3 + 0.99*alli ! 99% is gone + real, parameter :: qprismax = uiicet3 + 0.99*alli ! 99% is gone !---------------------------------------------------------------------------------------! !----- Coefficients to compute the thermal conductivity --------------------------------! @@ -273,9 +279,9 @@ subroutine nullify_sedimtab(sedtab) implicit none type (pcp_tab_type), intent(inout) :: sedtab - if (associated(sedtab%pcpfillc)) nullify (sedtab%pcpfillc) - if (associated(sedtab%pcpfillr)) nullify (sedtab%pcpfillr) - if (associated(sedtab%sfcpcp )) nullify (sedtab%sfcpcp ) + nullify (sedtab%pcpfillc) + nullify (sedtab%pcpfillr) + nullify (sedtab%sfcpcp ) return end subroutine nullify_sedimtab diff --git a/BRAMS/src/mksfc/geodat.f90 b/BRAMS/src/mksfc/geodat.f90 index 224528ac6..f6c219fda 100644 --- a/BRAMS/src/mksfc/geodat.f90 +++ b/BRAMS/src/mksfc/geodat.f90 @@ -576,7 +576,8 @@ subroutine dtedint(no,iwres,lon,lat,notfnd,pathname,dato) ! new input data holding arrays: real readin2(360000) -character*16 newname1*str_len,fmtstr*5,newne*6 +character(len=str_len) :: newname1 +character(len=5) :: fmtstr character*3 degns,degew character*12 dtedfile character*4 subdir diff --git a/BRAMS/src/mksfc/landuse_input.F90 b/BRAMS/src/mksfc/landuse_input.F90 index 0d6de2332..ca04234cf 100644 --- a/BRAMS/src/mksfc/landuse_input.F90 +++ b/BRAMS/src/mksfc/landuse_input.F90 @@ -772,8 +772,10 @@ subroutine read_header(ofn,iblksizo,no,isbego,iwbego,offlat,offlon,deltallo & implicit none integer :: iblksizo,no,isbego,iwbego,lb real :: offlat,offlon,deltallo -character :: ofn*(*),title*str_len,ifield*(*) -character :: h5name*(*) +character(len=*) :: ofn +character(len=str_len) :: title +character(len=*) :: ifield +character(len=*) :: h5name lb = len_trim(ofn) @@ -834,7 +836,9 @@ subroutine fill_datp(n2,n3,no,iblksizo,isbego,iwbego & real :: rio,rjo,rno,platn,plonn,offlat,offlon & ,glatp1,glonp1,deltallo,wio2,wjo2,wio1,wjo1 -character :: title1*3,title2*4,title3*str_len +character(len=3) :: title1 +character(len=4) :: title2 +character(len=str_len) :: title3 logical l1,l2,h5,missing integer :: ndims,idims(4),ii,jj diff --git a/BRAMS/src/mksfc/mksfc_driver.f90 b/BRAMS/src/mksfc/mksfc_driver.f90 index 933005e51..da5abf794 100644 --- a/BRAMS/src/mksfc/mksfc_driver.f90 +++ b/BRAMS/src/mksfc/mksfc_driver.f90 @@ -107,7 +107,10 @@ subroutine make_sfcfiles() !srf : para Itanium II com runtype=history !allocate( sfcfile_p(ngrids) ) - if(allocated(sfcfile_p)) deallocate(sfcfile_p);allocate(sfcfile_p(ngrids)) + if (allocated(sfcfile_p)) then + deallocate(sfcfile_p) + end if + allocate(sfcfile_p(ngrids)) do ifm = 1,ngrids call alloc_sfcfile(sfcfile_p(ifm),nnxp(ifm),nnyp(ifm),nzg,npatch) end do diff --git a/BRAMS/src/mnt_advec/mem_mnt_advec.f90 b/BRAMS/src/mnt_advec/mem_mnt_advec.f90 new file mode 100644 index 000000000..74b1ad17b --- /dev/null +++ b/BRAMS/src/mnt_advec/mem_mnt_advec.f90 @@ -0,0 +1,327 @@ +!==========================================================================================! +!==========================================================================================! +! Module mem_mnt_advec.f90 ! +! ! +! This module holds several variables that will help in the advection schemes. ! +!------------------------------------------------------------------------------------------! +module mem_mnt_advec + implicit none + + !---------------------------------------------------------------------------------------! + ! Structure with the auxiliary variables to be used by the advection scheme. ! + !---------------------------------------------------------------------------------------! + type advec_vars + !----- scratch 3d wind variables to be used within the advection scheme. ------------! + real,pointer,dimension (:,:,:) :: uavg + real,pointer,dimension (:,:,:) :: vavg + real,pointer,dimension (:,:,:) :: wavg + !------------------------------------------------------------------------------------! + + + !----- scratch 3d scalars to be used within the advection scheme. -------------------! + real,pointer,dimension (:,:,:) :: scal_in + real,pointer,dimension (:,:,:) :: scal_out + !------------------------------------------------------------------------------------! + + + + !----- 3D version of density for the advection scheme. ------------------------------! + real,pointer,dimension (:,:,:) :: denst + real,pointer,dimension (:,:,:) :: densu + real,pointer,dimension (:,:,:) :: densv + real,pointer,dimension (:,:,:) :: densw + !------------------------------------------------------------------------------------! + + + !----- Densities as definied in the Walcek papers. ----------------------------------! + real,pointer,dimension (:,:,:) :: den0_wal + real,pointer,dimension (:,:,:) :: den1_wal + real,pointer,dimension (:,:,:) :: den2_wal + real,pointer,dimension (:,:,:) :: den3_wal + !------------------------------------------------------------------------------------! + + + + !----- Grid spacing. ----------------------------------------------------------------! + real,pointer,dimension (:,:,:) :: dxtw + real,pointer,dimension (:,:,:) :: dytw + real,pointer,dimension (:,:,:) :: dztw + !------------------------------------------------------------------------------------! + end type advec_vars + type(advec_vars), dimension(:), allocatable :: advec_g + type(advec_vars), dimension(:), allocatable :: advecm_g + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! Variable to be read in from the namelist. ! + !---------------------------------------------------------------------------------------! + integer :: iadvec ! 0 -- original advection scheme + ! 1 -- monotonic advection (Freitas et al, in press, JAMES) + !---------------------------------------------------------------------------------------! + + + !=======================================================================================! + !=======================================================================================! + + + contains + + + + !=======================================================================================! + !=======================================================================================! + subroutine alloc_advec(advec,n1,n2,n3) + implicit none + !----- Arguments. -------------------------------------------------------------------! + type(advec_vars), intent(inout) :: advec + integer , intent(in) :: n1 + integer , intent(in) :: n2 + integer , intent(in) :: n3 + !------------------------------------------------------------------------------------! + + + allocate(advec%uavg (n1,n2,n3)) + allocate(advec%vavg (n1,n2,n3)) + allocate(advec%wavg (n1,n2,n3)) + allocate(advec%scal_in (n1,n2,n3)) + allocate(advec%scal_out (n1,n2,n3)) + allocate(advec%denst (n1,n2,n3)) + allocate(advec%densu (n1,n2,n3)) + allocate(advec%densv (n1,n2,n3)) + allocate(advec%densw (n1,n2,n3)) + allocate(advec%den0_wal (n1,n2,n3)) + allocate(advec%den1_wal (n1,n2,n3)) + allocate(advec%den2_wal (n1,n2,n3)) + allocate(advec%den3_wal (n1,n2,n3)) + allocate(advec%dxtw (n1,n2,n3)) + allocate(advec%dytw (n1,n2,n3)) + allocate(advec%dztw (n1,n2,n3)) + + return + end subroutine alloc_advec + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + subroutine nullify_advec(advec) + implicit none + !----- Arguments. -------------------------------------------------------------------! + type(advec_vars), intent(inout) :: advec + !------------------------------------------------------------------------------------! + + + nullify(advec%uavg ) + nullify(advec%vavg ) + nullify(advec%wavg ) + nullify(advec%scal_in ) + nullify(advec%scal_out ) + nullify(advec%denst ) + nullify(advec%densu ) + nullify(advec%densv ) + nullify(advec%densw ) + nullify(advec%den0_wal ) + nullify(advec%den1_wal ) + nullify(advec%den2_wal ) + nullify(advec%den3_wal ) + nullify(advec%dxtw ) + nullify(advec%dytw ) + nullify(advec%dztw ) + + return + end subroutine nullify_advec + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + subroutine zero_advec(advec) + implicit none + !----- Arguments. -------------------------------------------------------------------! + type(advec_vars), intent(inout) :: advec + !------------------------------------------------------------------------------------! + + + if (associated(advec%uavg )) advec%uavg = 0.0 + if (associated(advec%vavg )) advec%vavg = 0.0 + if (associated(advec%wavg )) advec%wavg = 0.0 + if (associated(advec%scal_in )) advec%scal_in = 0.0 + if (associated(advec%scal_out )) advec%scal_out = 0.0 + if (associated(advec%denst )) advec%denst = 0.0 + if (associated(advec%densu )) advec%densu = 0.0 + if (associated(advec%densv )) advec%densv = 0.0 + if (associated(advec%densw )) advec%densw = 0.0 + if (associated(advec%den0_wal )) advec%den0_wal = 0.0 + if (associated(advec%den1_wal )) advec%den1_wal = 0.0 + if (associated(advec%den2_wal )) advec%den2_wal = 0.0 + if (associated(advec%den3_wal )) advec%den3_wal = 0.0 + if (associated(advec%dxtw )) advec%dxtw = 0.0 + if (associated(advec%dytw )) advec%dytw = 0.0 + if (associated(advec%dztw )) advec%dztw = 0.0 + + return + end subroutine zero_advec + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + subroutine dealloc_advec(advec) + implicit none + !----- Arguments. -------------------------------------------------------------------! + type(advec_vars), intent(inout) :: advec + !------------------------------------------------------------------------------------! + + + if (associated(advec%uavg )) deallocate(advec%uavg ) + if (associated(advec%vavg )) deallocate(advec%vavg ) + if (associated(advec%wavg )) deallocate(advec%wavg ) + if (associated(advec%scal_in )) deallocate(advec%scal_in ) + if (associated(advec%scal_out )) deallocate(advec%scal_out ) + if (associated(advec%denst )) deallocate(advec%denst ) + if (associated(advec%densu )) deallocate(advec%densu ) + if (associated(advec%densv )) deallocate(advec%densv ) + if (associated(advec%densw )) deallocate(advec%densw ) + if (associated(advec%den0_wal )) deallocate(advec%den0_wal ) + if (associated(advec%den1_wal )) deallocate(advec%den1_wal ) + if (associated(advec%den2_wal )) deallocate(advec%den2_wal ) + if (associated(advec%den3_wal )) deallocate(advec%den3_wal ) + if (associated(advec%dxtw )) deallocate(advec%dxtw ) + if (associated(advec%dytw )) deallocate(advec%dytw ) + if (associated(advec%dztw )) deallocate(advec%dztw ) + + return + end subroutine dealloc_advec + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + subroutine filltab_advec(advec,advecm,imean,n1,n2,n3,ng) + use var_tables + + implicit none + !----- Arguments. -------------------------------------------------------------------! + type(advec_vars) , intent(in) :: advec + type(advec_vars) , intent(in) :: advecm + integer , intent(in) :: imean + integer , intent(in) :: n1 + integer , intent(in) :: n2 + integer , intent(in) :: n3 + integer , intent(in) :: ng + !----- Local variables. -------------------------------------------------------------! + integer :: npts + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! 3-D variables, exchanged at the main advectiom time step for. ! + !------------------------------------------------------------------------------------! + npts = n1 * n2 * n3 + + if (associated(advec%uavg )) & + call vtables2(advec%uavg,advecm%uavg,ng,npts,imean & + ,'UAVG :3:mpti:mpt3:advu') + + if (associated(advec%vavg )) & + call vtables2(advec%vavg,advecm%vavg,ng,npts,imean & + ,'VAVG :3:mpti:mpt3:advv') + + if (associated(advec%wavg )) & + call vtables2(advec%wavg,advecm%wavg,ng,npts,imean & + ,'WAVG :3:mpti:mpt3:advw') + + if (associated(advec%denst )) & + call vtables2(advec%denst,advecm%denst,ng,npts,imean & + ,'DENST :3:mpti:mpt3:advt') + + if (associated(advec%densu )) & + call vtables2(advec%densu,advecm%densu,ng,npts,imean & + ,'DENSU :3:mpti:mpt3:advu') + + if (associated(advec%densv )) & + call vtables2(advec%densv,advecm%densv,ng,npts,imean & + ,'DENSV :3:mpti:mpt3:advv') + + if (associated(advec%densw )) & + call vtables2(advec%densw,advecm%densw,ng,npts,imean & + ,'DENSW :3:mpti:mpt3:advw') + + if (associated(advec%den0_wal )) & + call vtables2(advec%den0_wal,advecm%den0_wal,ng,npts,imean & + ,'DEN0_WAL :3:mpti:mpt3:advt') + + if (associated(advec%den1_wal )) & + call vtables2(advec%den1_wal,advecm%den1_wal,ng,npts,imean & + ,'DEN1_WAL :3:mpti:mpt3:advt') + + if (associated(advec%den2_wal )) & + call vtables2(advec%den2_wal,advecm%den2_wal,ng,npts,imean & + ,'DEN2_WAL :3:mpti:mpt3:advt') + + if (associated(advec%den3_wal )) & + call vtables2(advec%den3_wal,advecm%den3_wal,ng,npts,imean & + ,'DEN3_WAL :3:mpti:mpt3:advt') + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Grid variables, save as 3-D variables for convenience. They are exchanged ! + ! only at the beginning. ! + !------------------------------------------------------------------------------------! + if (associated(advec%dxtw )) & + call vtables2(advec%dxtw,advecm%dxtw,ng,npts,imean & + ,'DXTW :3:mpti:mpt3') + + if (associated(advec%dytw )) & + call vtables2(advec%dytw,advecm%dytw,ng,npts,imean & + ,'DYTW :3:mpti:mpt3') + + if (associated(advec%dztw )) & + call vtables2(advec%dztw,advecm%dztw,ng,npts,imean & + ,'DZTW :3:mpti:mpt3') + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Scalar temporary array. We copy them at specific times within the time step. ! + !------------------------------------------------------------------------------------! + if (associated(advec%scal_in )) & + call vtables2(advec%scal_in,advecm%scal_in,ng,npts,imean & + ,'SCAL_IN :3:mpti:mpt3') + + if (associated(advec%scal_out )) & + call vtables2(advec%scal_out,advecm%scal_out,ng,npts,imean & + ,'SCAL_OUT :3:mpti:mpt3') + !------------------------------------------------------------------------------------! + + return + end subroutine filltab_advec + !=======================================================================================! + !=======================================================================================! +end module mem_mnt_advec +!==========================================================================================! +!==========================================================================================! diff --git a/BRAMS/src/mnt_advec/mnt_advec_aux.f90 b/BRAMS/src/mnt_advec/mnt_advec_aux.f90 new file mode 100644 index 000000000..598c730f9 --- /dev/null +++ b/BRAMS/src/mnt_advec/mnt_advec_aux.f90 @@ -0,0 +1,334 @@ +!==========================================================================================! +!==========================================================================================! +! This subroutine initialises the vectors containing the grid spacing vectors (actual- ! +! ly the inverse of the grid spacing), so we don't need to recalculate them every time we ! +! advect stuff. ! +!------------------------------------------------------------------------------------------! +subroutine init_grid_spacing(m1,m2,m3,dxt,dyt,dzt,fmapt,rtgt,dxtw,dytw,dztw) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: m1 + integer , intent(in) :: m2 + integer , intent(in) :: m3 + real , dimension( m2,m3), intent(in) :: dxt + real , dimension( m2,m3), intent(in) :: dyt + real , dimension(m1 ), intent(in) :: dzt + real , dimension( m2,m3), intent(in) :: fmapt + real , dimension( m2,m3), intent(in) :: rtgt + real , dimension(m1,m2,m3), intent(out) :: dxtw + real , dimension(m1,m2,m3), intent(out) :: dytw + real , dimension(m1,m2,m3), intent(out) :: dztw + !----- Local variables. ----------------------------------------------------------------! + integer :: i + integer :: j + integer :: k + real :: rtgti + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! Loop over the horizontal grid points. The Jacobian doesn't depend on Z, so dztw ! + ! depends only on Z. ! + !---------------------------------------------------------------------------------------! + do j=1,m3 + do i=1,m2 + rtgti = 1.0 / rtgt(i,j) + + do k=1,m1 + dxtw(k,i,j) = 1.0 / (dxt(i,j) * fmapt(i,j) * rtgti) + dytw(k,i,j) = 1.0 / (dyt(i,j) * fmapt(i,j) * rtgti) + dztw(k,i,j) = 1.0 / dzt(k) + end do + end do + end do + !---------------------------------------------------------------------------------------! + + return +end subroutine init_grid_spacing +!==========================================================================================! +!==========================================================================================! + + + + + +!==========================================================================================! +!==========================================================================================! +! BRAMS often uses the reference density, but in the new advection we must use the ! +! actual densities. ! +!------------------------------------------------------------------------------------------! +subroutine find_actual_densities(m1,m2,m3,rtp,rv,pp,pi0,theta,denst,densu,densv,densw) + use therm_lib , only : virtt & ! function + , exner2press & ! function + , extheta2temp ! ! function + use rconstants, only : rdry ! ! intent(in) + implicit none + !------ Arguments. ---------------------------------------------------------------------! + integer , intent(in) :: m1 + integer , intent(in) :: m2 + integer , intent(in) :: m3 + real , dimension(m1,m2,m3), intent(in) :: rtp + real , dimension(m1,m2,m3), intent(in) :: rv + real , dimension(m1,m2,m3), intent(in) :: pp + real , dimension(m1,m2,m3), intent(in) :: pi0 + real , dimension(m1,m2,m3), intent(in) :: theta + real , dimension(m1,m2,m3), intent(inout) :: denst + real , dimension(m1,m2,m3), intent(inout) :: densu + real , dimension(m1,m2,m3), intent(inout) :: densv + real , dimension(m1,m2,m3), intent(inout) :: densw + !----- Local variables. ----------------------------------------------------------------! + integer :: i + integer :: j + integer :: k + real :: exner + real :: pres + real :: temp + real :: tvir + !---------------------------------------------------------------------------------------! + + + !----- Check whether this run has water vapour or not. ---------------------------------! + do j=1,m3 + do i=1,m2 + do k=1,m1 + !----- Find pressure and temperature. -----------------------------------------! + exner = pi0(k,i,j) + pp(k,i,j) + pres = exner2press(exner) + temp = extheta2temp(exner,theta(k,i,j)) + !----- Find the virtual temperature. ------------------------------------------! + tvir = virtt(temp,rv(k,i,j),rtp(k,i,j)) + !----- Density comes from gas law using virtual temperature. ------------------! + denst(k,i,j) = pres / (rdry * tvir) + !------------------------------------------------------------------------------! + end do + end do + end do + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! Find the densities at the u and v grid points. ! + !---------------------------------------------------------------------------------------! + call fill_dn0uv(m1,m2,m3,denst,densu,densv) + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! Find the densities at the w grid points. ! + !---------------------------------------------------------------------------------------! + do j=1,m3 + do i=1,m2 + do k=1,m1-1 + densw(k,i,j) = 0.5 * (denst(k,i,j) + denst(k+1,i,j)) + end do + densw(m1,i,j) = densw(m1-1,i,j) + end do + end do + !---------------------------------------------------------------------------------------! + + return +end subroutine find_actual_densities +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +! This subroutine finds the average winds for the advection, and stores the values on ! +! the "mid" variables. ! +!------------------------------------------------------------------------------------------! +subroutine find_avg_winds(m1,m2,m3,ia,iz,ja,jz,ka,kz,uc,up,vc,vp,wc,wp,fmapui,fmapvi & + ,rtgt,rtgu,rtgv,f13t,f23t,uavg,vavg,wavg) + use mem_grid, only : hw4 ! ! intent(in) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: m1 + integer , intent(in) :: m2 + integer , intent(in) :: m3 + integer , intent(in) :: ia + integer , intent(in) :: iz + integer , intent(in) :: ja + integer , intent(in) :: jz + integer , intent(in) :: ka + integer , intent(in) :: kz + real , dimension(m1,m2,m3), intent(in) :: uc + real , dimension(m1,m2,m3), intent(in) :: up + real , dimension(m1,m2,m3), intent(in) :: vc + real , dimension(m1,m2,m3), intent(in) :: vp + real , dimension(m1,m2,m3), intent(in) :: wc + real , dimension(m1,m2,m3), intent(in) :: wp + real , dimension( m2,m3), intent(in) :: fmapui + real , dimension( m2,m3), intent(in) :: fmapvi + real , dimension( m2,m3), intent(in) :: rtgt + real , dimension( m2,m3), intent(in) :: rtgu + real , dimension( m2,m3), intent(in) :: rtgv + real , dimension( m2,m3), intent(in) :: f13t + real , dimension( m2,m3), intent(in) :: f23t + real , dimension(m1,m2,m3), intent(inout) :: uavg + real , dimension(m1,m2,m3), intent(inout) :: vavg + real , dimension(m1,m2,m3), intent(inout) :: wavg + !----- Local variables. ----------------------------------------------------------------! + integer :: i + integer :: j + integer :: k + integer :: im1 + integer :: ip1 + integer :: jm1 + integer :: jp1 + integer :: kp1 + real :: rtgti + real :: fmrt_u + real :: fmrt_v + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! Start by defining the ?mid terms as temporal averages using Cartesian ! + ! coordinates. ! + !---------------------------------------------------------------------------------------! + do j=1,m3 + do i=1,m2 + do k=1,m1 + uavg(k,i,j) = 0.5 * (uc(k,i,j) + up(k,i,j)) + vavg(k,i,j) = 0.5 * (vc(k,i,j) + vp(k,i,j)) + wavg(k,i,j) = 0.5 * (wc(k,i,j) + wp(k,i,j)) + end do + end do + end do + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! Terrain-following coordinate has slopes, and we must add the slope contribution ! + ! to the vertical component so it becomes a true sigma-z velocity. ! + !---------------------------------------------------------------------------------------! + do j=1,m3 + jm1 = max( 1,j-1) + jp1 = min(m3,j+1) + do i=1,m2 + im1 = max( 1,i-1) + ip1 = min(m2,i+1) + rtgti = 1.0 / rtgt(i,j) + + do k=1,kz + kp1 = k+1 + wavg(k,i,j) = hw4(k) & + * ( f13t(i,j) * ( uavg( k, i, j) + uavg(kp1, i, j) & + + uavg( k,im1, j) + uavg(kp1,im1, j) ) & + + f23t(i,j) * ( vavg( k, i, j) + vavg(kp1, i, j) & + + vavg( k, i,jm1) + vavg(kp1, i,jm1) ) ) & + + wavg(k,i,j) * rtgti + end do + end do + end do + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! Add the map factors to the horizontal winds. ! + !---------------------------------------------------------------------------------------! + do j=1,m3 + do i=1,m2 + fmrt_u = fmapui(i,j) * rtgu(i,j) + fmrt_v = fmapvi(i,j) * rtgv(i,j) + + do k=1,m1 + uavg(k,i,j) = uavg(k,i,j) * fmrt_u + vavg(k,i,j) = vavg(k,i,j) * fmrt_v + end do + + end do + end do + !---------------------------------------------------------------------------------------! + + return +end subroutine find_avg_winds +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +! This subroutine finds the density terms as in Walcek. ! +!------------------------------------------------------------------------------------------! +subroutine find_walcek_densities(dtime,m1,m2,m3,ia,iz,ja,jz,ka,kz,uavg,vavg,wavg & + ,denst,densu,densv,densw,den0_wal,den1_wal,den2_wal & + ,den3_wal,dxtw,dytw,dztw) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + real , intent(in) :: dtime + integer , intent(in) :: m1 + integer , intent(in) :: m2 + integer , intent(in) :: m3 + integer , intent(in) :: ia + integer , intent(in) :: iz + integer , intent(in) :: ja + integer , intent(in) :: jz + integer , intent(in) :: ka + integer , intent(in) :: kz + real , dimension(m1,m2,m3), intent(in) :: uavg + real , dimension(m1,m2,m3), intent(in) :: vavg + real , dimension(m1,m2,m3), intent(in) :: wavg + real , dimension(m1,m2,m3), intent(in) :: denst + real , dimension(m1,m2,m3), intent(in) :: densu + real , dimension(m1,m2,m3), intent(in) :: densv + real , dimension(m1,m2,m3), intent(in) :: densw + real , dimension(m1,m2,m3), intent(inout) :: den0_wal + real , dimension(m1,m2,m3), intent(inout) :: den1_wal + real , dimension(m1,m2,m3), intent(inout) :: den2_wal + real , dimension(m1,m2,m3), intent(inout) :: den3_wal + real , dimension(m1,m2,m3), intent(in) :: dxtw + real , dimension(m1,m2,m3), intent(in) :: dytw + real , dimension(m1,m2,m3), intent(in) :: dztw + !----- Local variables. ----------------------------------------------------------------! + integer :: i + integer :: j + integer :: k + integer :: im1 + integer :: jm1 + integer :: km1 + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! Find the four terms. ! + !---------------------------------------------------------------------------------------! + do j=ja,jz + jm1 = j-1 + do i=ia,iz + im1 = i-1 + do k=ka,kz + km1 = k-1 + + den0_wal(k,i,j) = denst(k,i,j) + den1_wal(k,i,j) = den0_wal(k,i,j) - dtime / dxtw(k,i,j) & + * ( densu( k, i, j) * uavg( k, i, j) & + - densu( k,im1, j) * uavg( k,im1, j) ) + den2_wal(k,i,j) = den1_wal(k,i,j) - dtime / dytw(k,i,j) & + * ( densv( k, i, j) * vavg( k, i, j) & + - densv( k, i,jm1) * vavg( k, i,jm1) ) + den3_wal(k,i,j) = den2_wal(k,i,j) - dtime / dztw(k,i,j) & + * ( densw( k, i, j) * wavg( k, i, j) & + - densw(km1, i, j) * wavg(km1, i, j) ) + end do + end do + end do + !---------------------------------------------------------------------------------------! + + return +end subroutine find_walcek_densities +!==========================================================================================! +!==========================================================================================! diff --git a/BRAMS/src/mnt_advec/mnt_advec_main.f90 b/BRAMS/src/mnt_advec/mnt_advec_main.f90 new file mode 100644 index 000000000..2b26c0ffc --- /dev/null +++ b/BRAMS/src/mnt_advec/mnt_advec_main.f90 @@ -0,0 +1,573 @@ +!==========================================================================================! +!==========================================================================================! +! Subroutine radvc_mnt.f90. This subroutine is the main driver for the monotic !! +! advection scheme. This was originally implemented by Saulo R. Freitas ! +! saulo.freitas@cptec.inpe.br) in June 2009, and it was originally parallelised by ! +! Luiz Flavio and Jairo Panneta. This advection scheme is highly conservative, monotonic, ! +! and it keeps the mass mixing ratio positive. ! +! ! +! The current version was adapted to BRAMS-4.0.6 by Marcos Longo in December 2011. In ! +! this version we don't use the additional memory, instead we try to follow the original ! +! wrapper functions. ! +! ! +! References: ! +! ! +! Walcek, C. J., N. M. Aleksic, 1998: A simple but accurate mass conservative, peak- ! +! -preserving, mixing ratio bounded advection algorithm with Fortran code. Atmos. ! +! Environ., 32, 3863-3880. ! +! Walcek, C. J., 2000: Minor flux adjustment near mixing ratio extremes for simplified ! +! yet highly accurate monotonic calculation of tracer advection. J. Geophys. Res., ! +! 105(D7), 9335-9348. ! +!------------------------------------------------------------------------------------------! +subroutine radvc_mnt_driver(m1,m2,m3,ia,iz,ja,jz,mynum) + + use grid_dims , only : maxgrds ! ! intent(in) + use mem_grid , only : ngrid & ! intent(in) + , grid_g & ! intent(in) + , dzt & ! intent(in) + , dtlt ! ! intent(in) + use mem_basic , only : basic_g ! ! intent(in) + use mem_mnt_advec, only : advec_g ! ! intent(in) + use var_tables , only : num_scalar & ! intent(in) + , scalar_tab ! ! intent(in) + use mem_scratch , only : vctr11 & ! Scratch for scal_in + , vctr12 & ! Scratch for uavg, vavg, wavg + , vctr13 & ! Scratch for den(i-1)_wal + , vctr14 & ! Scratch for den(i)_wal + , vctr15 & ! Scratch for densu, densv, densw + , vctr16 & ! Scratch for dxtw + , vctr17 ! ! Scratch for scal_out + implicit none + + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: m1 + integer , intent(in) :: m2 + integer , intent(in) :: m3 + integer , intent(in) :: ia + integer , intent(in) :: iz + integer , intent(in) :: ja + integer , intent(in) :: jz + integer , intent(in) :: mynum + !----- Local variables. ----------------------------------------------------------------! + integer :: nv + integer :: ka + integer :: kz + integer :: k + integer :: i + integer :: j + integer :: mzxyp + real , dimension(:) , pointer :: scalarp + real , dimension(:) , pointer :: scalart + !----- Locally saved variables. --------------------------------------------------------! + logical, dimension(maxgrds), save :: first_time = .true. + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! If this is the first time we call this subroutine, we must initialise the grid ! + ! spacing. ! + !---------------------------------------------------------------------------------------! + if (first_time(ngrid)) then + call init_grid_spacing( m1, m2, m3, grid_g (ngrid)%dxt , grid_g (ngrid)%dyt & + , dzt , grid_g (ngrid)%fmapt & + , grid_g (ngrid)%rtgt , advec_g(ngrid)%dxtw & + , advec_g(ngrid)%dytw , advec_g(ngrid)%dztw ) + first_time(ngrid) = .false. + end if + !---------------------------------------------------------------------------------------! + + + + !----- Alias for number of volume points in this node's sub-domain. --------------------! + mzxyp = m1 * m2 * m3 + !---------------------------------------------------------------------------------------! + + + + !----- Alias for first and last levels to be computed. ---------------------------------! + ka = 2 + kz = m1-1 + !---------------------------------------------------------------------------------------! + + + + !----- Find actual air densities. ------------------------------------------------------! + call find_actual_densities( m1, m2, m3, basic_g(ngrid)%rtp , basic_g(ngrid)%rv & + , basic_g(ngrid)%pp , basic_g(ngrid)%pi0 & + , basic_g(ngrid)%theta , advec_g(ngrid)%denst & + , advec_g(ngrid)%densu , advec_g(ngrid)%densv & + , advec_g(ngrid)%densw ) + !---------------------------------------------------------------------------------------! + + + + !----- Find the winds that will be used by the advection scheme. -----------------------! + call find_avg_winds( m1, m2, m3, ia, iz, ja, jz, ka, kz & + , basic_g(ngrid)%uc , basic_g(ngrid)%up & + , basic_g(ngrid)%vc , basic_g(ngrid)%vp & + , basic_g(ngrid)%wc , basic_g(ngrid)%wp & + , grid_g (ngrid)%fmapui, grid_g (ngrid)%fmapvi & + , grid_g (ngrid)%rtgt , grid_g (ngrid)%rtgu & + , grid_g (ngrid)%rtgv , grid_g (ngrid)%f13t & + , grid_g (ngrid)%f23t , advec_g(ngrid)%uavg & + , advec_g(ngrid)%vavg , advec_g(ngrid)%wavg ) + !---------------------------------------------------------------------------------------! + + + + !----- Find the Walcek's density terms. ------------------------------------------------! + call find_walcek_densities( dtlt, m1, m2, m3, ia, iz, ja, jz, ka, kz & + , advec_g(ngrid)%uavg , advec_g(ngrid)%vavg & + , advec_g(ngrid)%wavg , advec_g(ngrid)%denst & + , advec_g(ngrid)%densu , advec_g(ngrid)%densv & + , advec_g(ngrid)%densw , advec_g(ngrid)%den0_wal & + , advec_g(ngrid)%den1_wal, advec_g(ngrid)%den2_wal & + , advec_g(ngrid)%den3_wal, advec_g(ngrid)%dxtw & + , advec_g(ngrid)%dytw , advec_g(ngrid)%dztw ) + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! Exchange the boundary conditions for most fields. ! + !---------------------------------------------------------------------------------------! + call mpilbc_driver('fulladv',0) + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! Loop over all scalars. ! + !---------------------------------------------------------------------------------------! + do nv=1,num_scalar(ngrid) + !----- Use some pointers to make it easier to read. ---------------------------------! + scalarp => scalar_tab(nv,ngrid)%var_p + scalart => scalar_tab(nv,ngrid)%var_t + !------------------------------------------------------------------------------------! + + + + !----- Copy the scalar to the advection scratch array and update boundaries. --------! + call atob(mzxyp,scalarp,advec_g(ngrid)%scal_in ) + call mpilbc_driver('fulladv',5) + call atob(mzxyp,advec_g(ngrid)%scal_in,advec_g(ngrid)%scal_out) + !------------------------------------------------------------------------------------! + + + + !----- Make the advection for the X direction. --------------------------------------! + do j=ja,jz + do k=2,m1-1 + !----- Copy vectors to the scratch vectors. -----------------------------------! + call array2xcol(m1,m2,m3,k,j,advec_g(ngrid)%scal_in ,vctr11) + call array2xcol(m1,m2,m3,k,j,advec_g(ngrid)%uavg ,vctr12) + call array2xcol(m1,m2,m3,k,j,advec_g(ngrid)%den0_wal,vctr13) + call array2xcol(m1,m2,m3,k,j,advec_g(ngrid)%den1_wal,vctr14) + call array2xcol(m1,m2,m3,k,j,advec_g(ngrid)%densu ,vctr15) + call array2xcol(m1,m2,m3,k,j,advec_g(ngrid)%dxtw ,vctr16) + !------------------------------------------------------------------------------! + + + + !----- Solve the monotonic advection. -----------------------------------------! + call monotonic_advec(m2,ia,iz,dtlt,vctr11,vctr12,vctr13,vctr14,vctr15,vctr16 & + ,vctr17) + !------------------------------------------------------------------------------! + + + + !----- Copy solution back to the output array. --------------------------------! + call xcol2array(m1,m2,m3,k,j,vctr17,advec_g(ngrid)%scal_out) + !------------------------------------------------------------------------------! + end do + end do + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Copy the output to the input and exchange B.C. before we run the advection for ! + ! the Y direction. ! + !------------------------------------------------------------------------------------! + call atob(mzxyp,advec_g(ngrid)%scal_out,advec_g(ngrid)%scal_in) + call mpilbc_driver('fulladv',5) + call atob(mzxyp,advec_g(ngrid)%scal_in,advec_g(ngrid)%scal_out) + !------------------------------------------------------------------------------------! + + + + !----- Make the advection for the Y direction. --------------------------------------! + do i=ia,iz + do k=2,m1-1 + !----- Copy vectors to the scratch vectors. -----------------------------------! + call array2ycol(m1,m2,m3,k,i,advec_g(ngrid)%scal_in ,vctr11) + call array2ycol(m1,m2,m3,k,i,advec_g(ngrid)%vavg ,vctr12) + call array2ycol(m1,m2,m3,k,i,advec_g(ngrid)%den1_wal,vctr13) + call array2ycol(m1,m2,m3,k,i,advec_g(ngrid)%den2_wal,vctr14) + call array2ycol(m1,m2,m3,k,i,advec_g(ngrid)%densv ,vctr15) + call array2ycol(m1,m2,m3,k,i,advec_g(ngrid)%dytw ,vctr16) + !------------------------------------------------------------------------------! + + + + !----- Solve the monotonic advection. -----------------------------------------! + call monotonic_advec(m3,ja,jz,dtlt,vctr11,vctr12,vctr13,vctr14,vctr15,vctr16 & + ,vctr17) + !------------------------------------------------------------------------------! + + + + !----- Copy solution back to the output array. --------------------------------! + call ycol2array(m1,m2,m3,k,i,vctr17,advec_g(ngrid)%scal_out) + !------------------------------------------------------------------------------! + end do + end do + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Copy the output to the input and exchange B.C. before we run the advection for ! + ! the Z direction. ! + !------------------------------------------------------------------------------------! + call atob(mzxyp,advec_g(ngrid)%scal_out,advec_g(ngrid)%scal_in) + call mpilbc_driver('fulladv',5) + call atob(mzxyp,advec_g(ngrid)%scal_in,advec_g(ngrid)%scal_out) + !------------------------------------------------------------------------------------! + + + + !----- Make the advection for the Y direction. --------------------------------------! + do j=ja,jz + do i=ia,iz + !----- Copy vectors to the scratch vectors. -----------------------------------! + call array2zcol(m1,m2,m3,i,j,advec_g(ngrid)%scal_in ,vctr11) + call array2zcol(m1,m2,m3,i,j,advec_g(ngrid)%wavg ,vctr12) + call array2zcol(m1,m2,m3,i,j,advec_g(ngrid)%den2_wal,vctr13) + call array2zcol(m1,m2,m3,i,j,advec_g(ngrid)%den3_wal,vctr14) + call array2zcol(m1,m2,m3,i,j,advec_g(ngrid)%densw ,vctr15) + call array2zcol(m1,m2,m3,i,j,advec_g(ngrid)%dztw ,vctr16) + !------------------------------------------------------------------------------! + + + + !----- Solve the monotonic advection. -----------------------------------------! + call monotonic_advec(m1,ka,kz,dtlt,vctr11,vctr12,vctr13,vctr14,vctr15,vctr16 & + ,vctr17) + !------------------------------------------------------------------------------! + + + + !----- Copy solution back to the output array. --------------------------------! + call zcol2array(m1,m2,m3,i,j,vctr17,advec_g(ngrid)%scal_out) + !------------------------------------------------------------------------------! + end do + end do + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Update the tendency due to advection. ! + !------------------------------------------------------------------------------------! + call advtndc(m1,m2,m3,ia,iz,ja,jz,scalarp,advec_g(ngrid)%scal_out,scalart,dtlt,mynum) + !------------------------------------------------------------------------------------! + end do + !---------------------------------------------------------------------------------------! + + return +end subroutine radvc_mnt_driver +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +! This subroutine calculates change in the analysed property qp during time step ! +! dtime due to advection along a grid that has npts points in a single direction. The ! +! property is loaded into the qp array, and the result is updated to qc. Velocities ! +! "wind" and fluxes "flux" are specified at the staggered grid points. ddim0 is the ! +! dimensionally dependent density before the advection of this term, whilst ddimm1 is the ! +! dimensionally dependent density including this direction. densp is the air density ! +! before the any advection. ! +! ! +! 1D grid -> | na | na+1 | ... | nz-1 | nz | ! +! Wind -> u(na-1) u(na) u(na+1) ... u(nz-1) u(nz) u(nz+1) ! +! Property -> | q(na) | q(na+1) | ... | q(nz-1) | q(nz) | ! +! Density -> d(na-1) d(na) d(na+1) ... d(nz-1) d(nz) d(nz+1) ! +! ! +! Boundary conditions for the Q arrays are stored at cells na-1 and nz+1. ! +! ! +! For this subroutine and comments, we use the some generic notation. Their actual ! +! meaning depends on the direction, and this table is the reference: ! +! ! +! /---------------------------------------------------------------------------------\ ! +! | Direction | Wind | npts | na | nz | delta_n | Left | Right | ! +! |-------------+--------+--------+--------+--------+----------+---------+----------| ! +! | X | uavg | m2 | ia | iz | dxtw | West | East | ! +! | Y | vavg | m3 | ja | jz | dytw | South | North | ! +! | Z | wavg | m1 | 2 | m1-1 | dztw | Nadir | Zenith | ! +! \---------------------------------------------------------------------------------/ ! +! ! +!------------------------------------------------------------------------------------------! +subroutine monotonic_advec(npts,na,nz,dtime,qp,wind,ddm1,ddp0,densn,delta_n,qc) + use therm_lib, only : toler ! ! intent(in) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: npts + integer , intent(in) :: na + integer , intent(in) :: nz + real , intent(in) :: dtime + real , dimension(npts), intent(in) :: qp + real , dimension(npts), intent(in) :: wind + real , dimension(npts), intent(in) :: ddm1 + real , dimension(npts), intent(in) :: ddp0 + real , dimension(npts), intent(in) :: densn + real , dimension(npts), intent(in) :: delta_n + real , dimension(npts), intent(inout) :: qc + !----- Local variables. ----------------------------------------------------------------! + integer :: n + integer :: nam1 + integer :: nzp1 + integer :: nm1 + integer :: np1 + logical, dimension(npts) :: extreme + logical :: locmax + logical :: locmin + real , dimension(npts) :: flux + real , dimension(npts) :: qcmin + real , dimension(npts) :: qcmax + real :: qleft + real :: qright + real :: qhalf + real :: qguess + real :: courant + real :: alpha + !---------------------------------------------------------------------------------------! + + + !----- Edge indices for winds. ---------------------------------------------------------! + nam1 = na - 1 + nzp1 = nz + 1 + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! Initialise the extreme indices as false so only the local extremes will be true. ! + !---------------------------------------------------------------------------------------! + extreme(:) = .false. + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! Initialise the "current" q with "previous" q so the indices outside the na:nz ! + ! range will have something. ! + !---------------------------------------------------------------------------------------! + qc(:) = qp(:) + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! Flag every local extreme. ! + !---------------------------------------------------------------------------------------! + do n=na,nz + !----- Auxiliary indices for neighbour cells. ---------------------------------------! + nm1 = n - 1 + np1 = n + 1 + !------------------------------------------------------------------------------------! + + + !----- Flag the point as an extreme if it is one. -----------------------------------! + locmax = qp(n) >= ( max(qp(nm1),qp(np1)) - toler ) + locmin = qp(n) <= ( max(qp(nm1),qp(np1)) + toler ) + extreme(n) = locmax .or. locmin + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! qcmin and qcmax are the absolute physical minimum limits to the property ! + ! qc ar time t + dtime. If these limits are ever violated, then a non-monotonic ! + ! (i.e. oscillatory) behaviour will happen. ! + !------------------------------------------------------------------------------------! + if (wind(nm1) >= 0.) then + qleft = qp(nm1) + else + qleft = qp(n) + end if + if (wind(n) < 0.) then + qright = qp(np1) + else + qright = qp(n) + end if + qcmin(n) = min(qp(n),qleft,qright) + qcmax(n) = max(qp(n),qleft,qright) + !------------------------------------------------------------------------------------! + end do + !---------------------------------------------------------------------------------------! + + + + !>->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->! + !>->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->! + ! We first solve the "left-to-right" flux. ! + !>->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->! + !>->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->! + !------ Leftmost boundary condition. ---------------------------------------------------! + if (wind(nam1) >= 0.0) flux(nam1) = qp(nam1) * wind(nam1) * dtime * densn(nam1) + !------ Update values for those points that are experiencing westerly advection. -------! + lrloop: do n=na,nz + nm1 = n - 1 + np1 = n + 1 + !----- Solve this point only if the winds are coming from the west. -----------------! + if (wind(n) >= 0.0) then + !---------------------------------------------------------------------------------! + ! Check whether there is only outflow from this grid point, or there is ! + ! inflow. ! + !---------------------------------------------------------------------------------! + if (wind(nm1) < 0.0) then + !----- Outflow only. ----------------------------------------------------------! + flux(n) = qp(n) * wind(n) * dtime * densn(n) + !------------------------------------------------------------------------------! + else + !----- Outflow and inflow, check stability. -----------------------------------! + + + + !----- Find the Courant number. -----------------------------------------------! + courant = dtime * wind(n) / delta_n(n) + !------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------! + ! Decide which alpha to use. ! + !------------------------------------------------------------------------------! + if (extreme(np1)) then + !----- The cell downwind is a local extreme. -------------------------------! + alpha = 1.75 - 0.45 * courant + elseif (extreme(nm1)) then + !----- The cell two cells upwind is a local extreme. -----------------------! + alpha = max(1.5, 1.2 + 0.6 * courant) + else + !----- Default is 1.0. -----------------------------------------------------! + alpha = 1.0 + end if + !------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------! + ! Find the q(i+1/2) term. ! + !------------------------------------------------------------------------------! + qhalf = qp(n) + 0.25 * (qp(np1) - qp(nm1)) * (1. - courant) * alpha + qhalf = min(max(qhalf,min(qp(n),qp(np1))),max(qp(n),qp(np1))) + !------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------! + ! Find the first guess for this qc. ! + !------------------------------------------------------------------------------! + qguess = ( qp(n) * ddm1(n) - courant * qhalf * densn(n) & + + flux(nm1)/delta_n(n) ) & + / ddp0(n) + !------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------! + ! Final bounded answer and the flux. ! + !------------------------------------------------------------------------------! + qc(n) = max(qcmin(n),min(qcmax(n),qguess)) + flux(n) = delta_n(n) * (qp(n)*ddm1(n) - qc(n)*ddp0(n)) + flux(nm1) + !------------------------------------------------------------------------------! + end if + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + end do lrloop + !>->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->! + !>->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->->! + + + + + !<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-= 0.) then + if (wind(n) < 0.) then + !------ Inflow-only cell. -----------------------------------------------------! + qguess = (qp(n)*ddm1(n) - flux(n)/delta_n(n) + flux(nm1)/delta_n(n)) / ddp0(n) + qc(n) = max(qcmin(n),min(qcmax(n),qguess)) + end if + else + !------ Outflow and inflow, check stability. -------------------------------------! + + !----- Find the Courant number. --------------------------------------------------! + courant = dtime * abs(wind(nm1)) / delta_n(n) + !---------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------! + ! Decide which alpha to use. ! + !---------------------------------------------------------------------------------! + if (extreme(nm1)) then + !----- The cell downwind is a local extreme. ----------------------------------! + alpha = 1.75 - 0.45 * courant + elseif (extreme(np1)) then + !----- The cell two cells upwind is a local extreme. --------------------------! + alpha = max(1.5, 1.2 + 0.6 * courant) + else + !----- Default is 1.0. --------------------------------------------------------! + alpha = 1.0 + end if + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! Find the q(i-1/2) term. ! + !---------------------------------------------------------------------------------! + qhalf = qp(n) + 0.25 * (qp(nm1) - qp(np1)) * (1. - courant) * alpha + qhalf = min(max(qhalf,min(qp(n),qp(nm1))),max(qp(n),qp(nm1))) + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! Find the first guess for this qc. ! + !---------------------------------------------------------------------------------! + qguess = (qp(n)*ddm1(n) - flux(n)/delta_n(n) - courant*qhalf*densn(nm1)) / ddp0(n) + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! Final bounded answer and the flux. ! + !---------------------------------------------------------------------------------! + qc(n) = max(qcmin(n),min(qcmax(n),qguess)) + flux(nm1) = delta_n(n) * (qc(n)*ddp0(n) - qp(n)*ddm1(n)) + flux(n) + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + end do rlloop + !<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-<-= jsouth .and. j <= jnorth + xloop: do i=1,mx + !----- Iabs is the absolute X position. ---------------------------------------! + iabs = i + ioff + !------------------------------------------------------------------------------! + ! Sanity check. ! + !------------------------------------------------------------------------------! + if (iabs < 1 .or. iabs > nx .or. jabs < 1 .or. jabs > ny) then + write (unit=*,fmt='(a)') '-------------------------------------------------' + write (unit=*,fmt='(a)') ' Point overboard!!!' + write (unit=*,fmt='(a)') '-------------------------------------------------' + write (unit=*,fmt='(a,1x,i6)') ' I = ',i + write (unit=*,fmt='(a,1x,i6)') ' IABS = ',iabs + write (unit=*,fmt='(a,1x,i6)') ' J = ',j + write (unit=*,fmt='(a,1x,i6)') ' JABS = ',jabs + write (unit=*,fmt='(a,1x,i6)') ' NZ = ',nz + write (unit=*,fmt='(a,1x,i6)') ' NX = ',nx + write (unit=*,fmt='(a,1x,i6)') ' NY = ',ny + write (unit=*,fmt='(a,1x,i6)') ' NE = ',ne + write (unit=*,fmt='(a,1x,i6)') ' MX = ',mx + write (unit=*,fmt='(a,1x,i6)') ' MY = ',my + write (unit=*,fmt='(a,1x,i6)') ' IOFF = ',ioff + write (unit=*,fmt='(a,1x,i6)') ' IWEST = ',iwest + write (unit=*,fmt='(a,1x,i6)') ' IEAST = ',ieast + write (unit=*,fmt='(a,1x,i6)') ' JOFF = ',joff + write (unit=*,fmt='(a,1x,i6)') ' JSOUTH = ',jsouth + write (unit=*,fmt='(a,1x,i6)') ' JNORTH = ',jnorth + write (unit=*,fmt='(a,1x,i6)') ' IND = ',ind + write (unit=*,fmt='(a,1x,i6)') ' NPTS = ',npts + write (unit=*,fmt='(a)') '-------------------------------------------------' + call abort_run('Grid point offset is wrong','ex_full_buff','mpass_full.f90') + end if + !------------------------------------------------------------------------------! + + + !----- Same as jcopy but for the X rows. --------------------------------------! + icopy = i >= iwest .and. i <= ieast + + zloop: do k=1,nz + !----- We always update ind, but we do not always copy to mydata. ----------! + ind = ind + 1 + + !----- Check whether this is copied or not. --------------------------------! + if (icopy .and. jcopy) then + mydata(k,iabs,jabs,l) = buff(ind) + end if + end do zloop + end do xloop + end do yloop + end do eloop + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! Sanity check. ! + !---------------------------------------------------------------------------------------! + if (ind /= npts) then + write (unit=*,fmt='(a)') '----------------------------------------------------------' + write (unit=*,fmt='(a)') ' Mismatch between expected buffer size and amount copied! ' + write (unit=*,fmt='(a)') '----------------------------------------------------------' + write (unit=*,fmt='(a,1x,i6)') ' NZ = ',nz + write (unit=*,fmt='(a,1x,i6)') ' NX = ',nx + write (unit=*,fmt='(a,1x,i6)') ' NY = ',ny + write (unit=*,fmt='(a,1x,i6)') ' NE = ',ne + write (unit=*,fmt='(a,1x,i6)') ' MX = ',mx + write (unit=*,fmt='(a,1x,i6)') ' MY = ',my + write (unit=*,fmt='(a,1x,i6)') ' IOFF = ',ioff + write (unit=*,fmt='(a,1x,i6)') ' IWEST = ',iwest + write (unit=*,fmt='(a,1x,i6)') ' IEAST = ',ieast + write (unit=*,fmt='(a,1x,i6)') ' JOFF = ',joff + write (unit=*,fmt='(a,1x,i6)') ' JSOUTH = ',jsouth + write (unit=*,fmt='(a,1x,i6)') ' JNORTH = ',jnorth + write (unit=*,fmt='(a,1x,i6)') ' IND = ',ind + write (unit=*,fmt='(a,1x,i6)') ' NPTS = ',npts + write (unit=*,fmt='(a)') '----------------------------------------------------------' + call abort_run('Incorrect buffer size','ex_full_buff','mpass_full.f90') + end if !---------------------------------------------------------------------------------------! return diff --git a/BRAMS/src/mpi/mpass_init.f90 b/BRAMS/src/mpi/mpass_init.f90 index c041afb62..4c049e5ae 100644 --- a/BRAMS/src/mpi/mpass_init.f90 +++ b/BRAMS/src/mpi/mpass_init.f90 @@ -73,41 +73,63 @@ subroutine masterput_nl(master_num) use grid_dims , only : str_len ! ! intent(in) use rpara use therm_lib , only : level & ! intent(in) - ,vapour_on & ! intent(in) - ,cloud_on & ! intent(in) - ,bulk_on ! ! intent(in) + , vapour_on & ! intent(in) + , cloud_on & ! intent(in) + , bulk_on ! ! intent(in) + use mem_mnt_advec , only : iadvec ! ! intent(in) use mem_mass , only : iexev & ! intent(in) - ,imassflx ! ! intent(in) - use grell_coms , only: closure_type & ! intent(in) - ,maxclouds & ! intent(in) - ,iupmethod & ! intent(in) - ,depth_min & ! intent(in) - ,cap_maxs & ! intent(in) - ,cld2prec & ! intent(in) - ,maxens_lsf & ! intent(in) - ,maxens_dyn & ! intent(in) - ,maxens_eff & ! intent(in) - ,maxens_cap & ! intent(in) - ,iupmethod & ! intent(in) - ,radius & ! intent(in) - ,zkbmax & ! intent(in) - ,max_heat & ! intent(in) - ,zcutdown & ! intent(in) - ,z_detr ! ! intent(in) + , imassflx ! ! intent(in) + use grell_coms , only : closure_type & ! intent(in) + , maxclouds & ! intent(in) + , iupmethod & ! intent(in) + , depth_min & ! intent(in) + , cap_maxs & ! intent(in) + , cld2prec & ! intent(in) + , maxens_lsf & ! intent(in) + , maxens_dyn & ! intent(in) + , maxens_eff & ! intent(in) + , maxens_cap & ! intent(in) + , iupmethod & ! intent(in) + , radius & ! intent(in) + , zkbmax & ! intent(in) + , max_heat & ! intent(in) + , zcutdown & ! intent(in) + , z_detr ! ! intent(in) use catt_start , only : catt ! ! intent(in) use emission_source_map, only : plumerise ! ! intent(in) use plume_utils , only : prfrq ! ! intent(in) use teb_spm_start , only : teb_spm ! ! intent(in) - use teb_vars_const , only : iteb,tminbld,nteb & ! intent(in) - ,rushh1,rushh2,daylight & ! intent(in) - ,d_road,tc_road,hc_road & ! intent(in) - ,d_wall,tc_wall,hc_wall & ! intent(in) - ,d_roof,tc_roof,hc_roof & ! intent(in) - ,nurbtype,ileafcod,z0_town & ! intent(in) - ,bld,bld_height,bld_hl_ratio & ! intent(in) - ,aroof,eroof,aroad,eroad & ! intent(in) - ,awall,ewall,htraf,hindu & ! intent(in) - ,pletraf,pleindu ! ! intent(in) + use teb_vars_const , only : iteb & ! intent(in) + , tminbld & ! intent(in) + , nteb & ! intent(in) + , rushh1 & ! intent(in) + , rushh2 & ! intent(in) + , daylight & ! intent(in) + , d_road & ! intent(in) + , tc_road & ! intent(in) + , hc_road & ! intent(in) + , d_wall & ! intent(in) + , tc_wall & ! intent(in) + , hc_wall & ! intent(in) + , d_roof & ! intent(in) + , tc_roof & ! intent(in) + , hc_roof & ! intent(in) + , nurbtype & ! intent(in) + , ileafcod & ! intent(in) + , z0_town & ! intent(in) + , bld & ! intent(in) + , bld_height & ! intent(in) + , bld_hl_ratio & ! intent(in) + , aroof & ! intent(in) + , eroof & ! intent(in) + , aroad & ! intent(in) + , eroad & ! intent(in) + , awall & ! intent(in) + , ewall & ! intent(in) + , htraf & ! intent(in) + , hindu & ! intent(in) + , pletraf & ! intent(in) + , pleindu ! ! intent(in) use mem_emiss , only : ichemi & ! intent(in) ,ichemi_in & ! intent(in) ,chemdata_in & ! intent(in) @@ -405,6 +427,7 @@ subroutine masterput_nl(master_num) call MPI_Bcast(ISWRTYP,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(ICUMFDBK,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(ICORFLG,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) + call MPI_Bcast(IADVEC,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(IEXEV,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(IMASSFLX,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) @@ -887,60 +910,80 @@ subroutine nodeget_nl use node_mod use grid_dims , only : str_len ! ! intent(in) use therm_lib , only : level & ! intent(out) - ,vapour_on & ! intent(out) - ,cloud_on & ! intent(out) - ,bulk_on ! ! intent(out) + , vapour_on & ! intent(out) + , cloud_on & ! intent(out) + , bulk_on ! ! intent(out) + use mem_mnt_advec , only : iadvec ! ! intent(out) use mem_mass , only : iexev & ! intent(out) - ,imassflx ! ! intent(out) - use grell_coms , only: closure_type & ! intent(out) - ,maxclouds & ! intent(out) - ,iupmethod & ! intent(out) - ,depth_min & ! intent(out) - ,cap_maxs & ! intent(out) - ,cld2prec & ! intent(out) - ,maxens_lsf & ! intent(out) - ,maxens_dyn & ! intent(out) - ,maxens_eff & ! intent(out) - ,maxens_cap & ! intent(out) - ,iupmethod & ! intent(out) - ,radius & ! intent(out) - ,zkbmax & ! intent(out) - ,max_heat & ! intent(out) - ,zcutdown & ! intent(out) - ,z_detr ! ! intent(out) + , imassflx ! ! intent(out) + use grell_coms , only : closure_type & ! intent(out) + , maxclouds & ! intent(out) + , iupmethod & ! intent(out) + , depth_min & ! intent(out) + , cap_maxs & ! intent(out) + , cld2prec & ! intent(out) + , maxens_lsf & ! intent(out) + , maxens_dyn & ! intent(out) + , maxens_eff & ! intent(out) + , maxens_cap & ! intent(out) + , iupmethod & ! intent(out) + , radius & ! intent(out) + , zkbmax & ! intent(out) + , max_heat & ! intent(out) + , zcutdown & ! intent(out) + , z_detr ! ! intent(out) use catt_start , only : catt ! ! intent(out) use emission_source_map, only : plumerise ! ! intent(out) use plume_utils , only : prfrq ! ! intent(out) use teb_spm_start , only : teb_spm ! ! intent(out) use teb_vars_const , only : iteb,tminbld,nteb & ! intent(out) - ,rushh1,rushh2,daylight & ! intent(out) - ,d_road,tc_road,hc_road & ! intent(out) - ,d_wall,tc_wall,hc_wall & ! intent(out) - ,d_roof,tc_roof,hc_roof & ! intent(out) - ,nurbtype,ileafcod,z0_town & ! intent(out) - ,bld,bld_height,bld_hl_ratio & ! intent(out) - ,aroof,eroof,aroad,eroad & ! intent(out) - ,awall,ewall,htraf,hindu & ! intent(out) - ,pletraf,pleindu ! ! intent(out) + , rushh1 & ! intent(out) + , rushh2 & ! intent(out) + , daylight & ! intent(out) + , d_road & ! intent(out) + , tc_road & ! intent(out) + , hc_road & ! intent(out) + , d_wall & ! intent(out) + , tc_wall & ! intent(out) + , hc_wall & ! intent(out) + , d_roof & ! intent(out) + , tc_roof & ! intent(out) + , hc_roof & ! intent(out) + , nurbtype & ! intent(out) + , ileafcod & ! intent(out) + , z0_town & ! intent(out) + , bld & ! intent(out) + , bld_height & ! intent(out) + , bld_hl_ratio & ! intent(out) + , aroof & ! intent(out) + , eroof & ! intent(out) + , aroad & ! intent(out) + , eroad & ! intent(out) + , awall & ! intent(out) + , ewall & ! intent(out) + , htraf & ! intent(out) + , hindu & ! intent(out) + , pletraf & ! intent(out) + , pleindu ! ! intent(out) use mem_emiss , only : ichemi & ! intent(out) - ,ichemi_in & ! intent(out) - ,chemdata_in & ! intent(out) - ,isource & ! intent(out) - ,weekdayin & ! intent(out) - ,efsat & ! intent(out) - ,efsun & ! intent(out) - ,eindno & ! intent(out) - ,eindno2 & ! intent(out) - ,eindpm & ! intent(out) - ,eindco & ! intent(out) - ,eindso2 & ! intent(out) - ,eindvoc & ! intent(out) - ,eveino & ! intent(out) - ,eveino2 & ! intent(out) - ,eveipm & ! intent(out) - ,eveico & ! intent(out) - ,eveiso2 & ! intent(out) - ,eveivoc ! intent(out) + , ichemi_in & ! intent(out) + , chemdata_in & ! intent(out) + , isource & ! intent(out) + , weekdayin & ! intent(out) + , efsat & ! intent(out) + , efsun & ! intent(out) + , eindno & ! intent(out) + , eindno2 & ! intent(out) + , eindpm & ! intent(out) + , eindco & ! intent(out) + , eindso2 & ! intent(out) + , eindvoc & ! intent(out) + , eveino & ! intent(out) + , eveino2 & ! intent(out) + , eveipm & ! intent(out) + , eveico & ! intent(out) + , eveiso2 & ! intent(out) + , eveivoc ! intent(out) use turb_coms , only : nna & ! intent(out) , nnb & ! intent(out) , nnc ! ! intent(out) @@ -1214,6 +1257,7 @@ subroutine nodeget_nl call MPI_Bcast(ISWRTYP,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(ICUMFDBK,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(ICORFLG,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) + call MPI_Bcast(IADVEC,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(IEXEV,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(IMASSFLX,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) @@ -1323,8 +1367,10 @@ subroutine nodeget_grid_dimens() include 'interface.h' include 'mpif.h' !----- Local variables -----------------------------------------------------------------! - integer :: nm,ierr,ng,zzz - integer, allocatable, dimension(:,:) :: node_buffs_tmp + integer :: nm + integer :: ierr + integer :: ng + integer :: zzz !---------------------------------------------------------------------------------------! @@ -1386,16 +1432,16 @@ subroutine nodeget_grid_dimens() !----- Assigning the node_mod shortcuts with the appropiate values. --------------------! do ng=1,ngrids - mmxp(ng)=nodemxp(mynum,ng) - mmyp(ng)=nodemyp(mynum,ng) - mmzp(ng)=nodemzp(mynum,ng) - mia(ng)=nodeia(mynum,ng) - miz(ng)=nodeiz(mynum,ng) - mja(ng)=nodeja(mynum,ng) - mjz(ng)=nodejz(mynum,ng) - mi0(ng)=nodei0(mynum,ng) - mj0(ng)=nodej0(mynum,ng) - mibcon(ng)=nodeibcon(mynum,ng) + mmxp(ng) = nodemxp(mynum,ng) + mmyp(ng) = nodemyp(mynum,ng) + mmzp(ng) = nodemzp(mynum,ng) + mia(ng) = nodeia(mynum,ng) + miz(ng) = nodeiz(mynum,ng) + mja(ng) = nodeja(mynum,ng) + mjz(ng) = nodejz(mynum,ng) + mi0(ng) = nodei0(mynum,ng) + mj0(ng) = nodej0(mynum,ng) + mibcon(ng) = nodeibcon(mynum,ng) end do write (unit=*,fmt='(a)') '---------------------------------------------------------' write (unit=*,fmt='(a,1x,i5)') 'In nodeget_grid_dimens, mynum=',mynum diff --git a/BRAMS/src/mpi/node_mod.f90 b/BRAMS/src/mpi/node_mod.f90 index dc58acf76..0a0fe228f 100644 --- a/BRAMS/src/mpi/node_mod.f90 +++ b/BRAMS/src/mpi/node_mod.f90 @@ -149,6 +149,7 @@ module node_mod integer :: nbuff_nest integer :: f_ndmd_size integer :: nbuff_st + integer :: nbuff_adv !---------------------------------------------------------------------------------------! integer, dimension(maxmach) :: irecv_req integer, dimension(maxmach) :: isend_req @@ -181,6 +182,7 @@ module node_mod type(pack_buffs), dimension( maxmach) :: node_buffs_feed type(pack_buffs), dimension( maxmach) :: node_buffs_nest type(pack_buffs), dimension(6,maxmach) :: node_buffs_st + type(pack_buffs), dimension(5,maxmach) :: node_buffs_adv !---------------------------------------------------------------------------------------! diff --git a/BRAMS/src/mpi/par_decomp.f90 b/BRAMS/src/mpi/par_decomp.f90 index 2a3622c89..fef76c62b 100644 --- a/BRAMS/src/mpi/par_decomp.f90 +++ b/BRAMS/src/mpi/par_decomp.f90 @@ -397,8 +397,8 @@ subroutine par_node_paths() ! 3 - meridional wind ! ! 4 - perturbation of the Exner function ! ! 3rd dimension : grid number ! - ! 4th dimension : source node ! - ! 5th dimension : destination node ! + ! 4th dimension : destination node ! + ! 5th dimension : source node ! !---------------------------------------------------------------------------------------! ipaths (:,:,:,:,:) = 0 igetpaths( :,:,:,:) = 0 diff --git a/BRAMS/src/mpi/para_init.f90 b/BRAMS/src/mpi/para_init.f90 index 9b9fd5d88..21c676877 100644 --- a/BRAMS/src/mpi/para_init.f90 +++ b/BRAMS/src/mpi/para_init.f90 @@ -31,7 +31,8 @@ subroutine node_decomp(init) !----- Arguments. ----------------------------------------------------------------------! logical , intent(in) :: init !----- Local variables. ----------------------------------------------------------------! - integer, dimension(ndim_types) :: npvar + integer, dimension(ndim_types) :: npvar_mpt1 + integer, dimension(ndim_types) :: npvar_mpt4 integer :: ngr integer :: idn integer :: isn @@ -50,6 +51,7 @@ subroutine node_decomp(init) integer :: num_lbc_buff integer :: num_nest_buff integer :: num_six_buff + integer :: num_adv_buff integer :: num_feed_buff integer :: itype integer :: i1 @@ -132,15 +134,27 @@ subroutine node_decomp(init) if (scalar_tab(nf,ifm)%name==scalar_tab(nc,icm)%name) nestvar=nestvar+1 end do end do + !------------------------------------------------------------------------------------! + !---- Find number of LBC variables to be communicated. ------------------------------! - npvar(:) = 0 + npvar_mpt1(:) = 0 + npvar_mpt4(:) = 0 do nv = 1,num_var(ng) - if (vtab_r(nv,ng)%impt1 == 1 ) then - idim = vtab_r(nv,ng)%idim_type - npvar(idim) = npvar(idim) + 1 + idim = vtab_r(nv,ng)%idim_type + !----- LBC variables. ------------------------------------------------------------! + if (vtab_r(nv,ng)%impt1 == 1 ) npvar_mpt1(idim) = npvar_mpt1(idim) + 1 + !---------------------------------------------------------------------------------! + + + !----- ADV variables. ------------------------------------------------------------! + if (vtab_r(nv,1)%iadvt == 1 .or. vtab_r(nv,1)%iadvu == 1 .or. & + vtab_r(nv,1)%iadvv == 1 .or. vtab_r(nv,1)%iadvw == 1 ) then + npvar_mpt4(idim) = npvar_mpt4(idim) + 1 end if + !---------------------------------------------------------------------------------! end do + !------------------------------------------------------------------------------------! sourcemach1: do isn=1,nmachs @@ -148,6 +162,7 @@ subroutine node_decomp(init) num_lbc_buff = 0 num_nest_buff = 0 num_six_buff = 0 + num_adv_buff = 0 num_feed_buff = 0 itype=1 @@ -163,12 +178,14 @@ subroutine node_decomp(init) !------ Add the total number of points to be sent. -------------------------! num_lbc_buff = 0 + num_adv_buff = 0 do idim =2,ndim_types call ze_dims(ng,idim,.true.,fdzp,fdep) - num_lbc_buff = num_lbc_buff + ixy * fdzp * fdep * npvar(idim) + num_lbc_buff = num_lbc_buff + ixy * fdzp * fdep * npvar_mpt1(idim) + num_adv_buff = num_adv_buff + ixy * fdzp * fdep * npvar_mpt4(idim) end do - - num_lbc_buff = num_lbc_buff + 2 *(sum(npvar(:)) + 100) + num_lbc_buff = num_lbc_buff + 2 *(sum(npvar_mpt1(:)) + 100) + num_adv_buff = num_adv_buff + 2 *(sum(npvar_mpt4(:)) + 100) end if !------------------------------------------------------------------------------! @@ -219,6 +236,7 @@ subroutine node_decomp(init) !------ Update the buffer size with the highest value so far. -----------------! lbc_buffs(1,idn,isn) = max( lbc_buffs(1,idn,isn) & , num_lbc_buff & + , num_adv_buff & , num_nest_buff & , num_six_buff & , num_feed_buff) @@ -244,11 +262,14 @@ subroutine node_decomp(init) ixy = (i2-i1+1)*(j2-j1+1) num_lbc_buff = 0 + num_adv_buff = 0 do idim =2,ndim_types call ze_dims(ng,idim,.true.,fdzp,fdep) - num_lbc_buff = num_lbc_buff + ixy * fdzp * fdep * npvar(idim) + num_lbc_buff = num_lbc_buff + ixy * fdzp * fdep * npvar_mpt1(idim) + num_adv_buff = num_adv_buff + ixy * fdzp * fdep * npvar_mpt4(idim) end do - num_lbc_buff = num_lbc_buff + 2*(sum(npvar(:)) + 100) + num_lbc_buff = num_lbc_buff + 2*(sum(npvar_mpt1(:)) + 100) + num_adv_buff = num_adv_buff + 2*(sum(npvar_mpt4(:)) + 100) end if itype = 5 @@ -283,6 +304,7 @@ subroutine node_decomp(init) lbc_buffs(2,idn,isn) = max( lbc_buffs(2,idn,isn) & , num_lbc_buff & + , num_adv_buff & , num_nest_buff & , num_six_buff & , num_feed_buff) diff --git a/BRAMS/src/mpi/paral.f90 b/BRAMS/src/mpi/paral.f90 index 14dd2b5c5..9a3c0b364 100644 --- a/BRAMS/src/mpi/paral.f90 +++ b/BRAMS/src/mpi/paral.f90 @@ -248,12 +248,14 @@ subroutine master_getanl(vtype) select case (trim(vtype)) !----- Instantaneous variables, use var_p pointer --------------------------------! case ('LITE') - call ex_full_buff(vtab_r(nv,ng)%var_p,scratch%scr1,fdzp,nnxp(ng),nnyp(ng) & - ,fdep,mlon,mlat,ioff,joff,iwest,ieast,jsouth,jnorth) + call ex_full_buff(vtab_r(nv,ng)%var_p,scratch%scr1,npts,fdzp,nnxp(ng) & + ,nnyp(ng),fdep,mlon,mlat,ioff,joff,iwest,ieast & + ,jsouth,jnorth) !----- Averaged variables, use var_m pointer -------------------------------------! case ('MEAN','BOTH') - call ex_full_buff(vtab_r(nv,ng)%var_m,scratch%scr1,fdzp,nnxp(ng),nnyp(ng) & - ,fdep,mlon,mlat,ioff,joff,iwest,ieast,jsouth,jnorth) + call ex_full_buff(vtab_r(nv,ng)%var_m,scratch%scr1,npts,fdzp,nnxp(ng) & + ,nnyp(ng),fdep,mlon,mlat,ioff,joff,iwest,ieast & + ,jsouth,jnorth) end select end do varloop end do machloop diff --git a/BRAMS/src/nesting/nest_intrp.f90 b/BRAMS/src/nesting/nest_intrp.f90 index cc2c37135..c2d3d0e29 100644 --- a/BRAMS/src/nesting/nest_intrp.f90 +++ b/BRAMS/src/nesting/nest_intrp.f90 @@ -20,8 +20,8 @@ subroutine fmrefs1d(ngbegin,ngend) ! Interpolate the fine mesh 1-d reference state variables. - c1 = rdry / (cp - rdry) - c2 = cp * (rdry / p00) ** c1 + c1 = rdry / (cpdry - rdry) + c2 = cpdry * (rdry / p00) ** c1 do ifm = ngbegin,ngend icm = nxtnest(ifm) if (icm .ge. 1) then @@ -88,8 +88,8 @@ subroutine fmrefs3d(ifm,mynum) ,scratch%scr1,scratch%scr2,grid_g(ifm)%topt,scratch%vt2da & ,nbounds(ifm)%bux,nbounds(ifm)%buy,nbounds(ifm)%buz,mynum) -c1 = rdry / (cp - rdry) -c2 = cp * (rdry / p00) ** c1 +c1 = rdry / (cpdry - rdry) +c2 = cpdry * (rdry / p00) ** c1 do j = 1,nnyp(ifm) do i = 1,nnxp(ifm) do k = 1,nnzp(ifm) diff --git a/BRAMS/src/oldgrell/cup_dn.f90 b/BRAMS/src/oldgrell/cup_dn.f90 index 62b6e7486..b4462faf3 100644 --- a/BRAMS/src/oldgrell/cup_dn.f90 +++ b/BRAMS/src/oldgrell/cup_dn.f90 @@ -38,7 +38,7 @@ end subroutine cup_dd_he subroutine cup_dd_moisture(j,zd,hcd,hes_cup,qcd,qes_cup,pwd,q_cup,z_cup,cdd & ,entr,jmin,ierr,gamma_cup,pwev,mix,mgmxp,mkx,mgmzp & ,istart,iend,bu,qrcd,q,he,hc,t_cup,iloop) - use rconstants, only : alvl + use rconstants, only : alvl3 implicit none integer :: mix,mgmxp,mkx,mgmzp,istart,iend,i,k,ki,j & ,iloop @@ -81,7 +81,7 @@ subroutine cup_dd_moisture(j,zd,hcd,hes_cup,qcd,qes_cup,pwd,q_cup,z_cup,cdd & DH=HCD(I,ki)-HES_cup(I,Ki) bu(i)=bu(i)+dz*dh - QRCD(I,Ki)=qes_cup(i,ki)+(1./alvl)*(GAMMA_cup(i,ki)/ & + QRCD(I,Ki)=qes_cup(i,ki)+(1./alvl3)*(GAMMA_cup(i,ki)/ & (1.+GAMMA_cup(i,ki)))*DH dqeva=qcd(i,ki)-qrcd(i,ki) if(dqeva.gt.0.) dqeva=0. @@ -143,7 +143,7 @@ end subroutine cup_dd_nms !-------------------------------------------------------------------- subroutine cup_dd_aa0(edt,ierr,aa0,jmin,gamma_cup,t_cup,hcd,hes_cup,z,mix & ,mgmxp,mkx,mgmzp,istart,iend,zd) - use rconstants, only : grav, cp + use rconstants, only : grav, cpdry implicit none integer :: i,k,kk,mix,mgmxp,mkx,mgmzp,istart,iend integer, dimension(mgmxp) :: jmin,ierr @@ -156,7 +156,7 @@ subroutine cup_dd_aa0(edt,ierr,aa0,jmin,gamma_cup,t_cup,hcd,hes_cup,z,mix & KK=JMIN(I)-K DZ=(Z(I,KK)-Z(I,KK+1)) - AA0(I)=AA0(I)+zd(i,kk)*EDT(I)*DZ*(grav/(cp*T_cup(I,KK)))* & + AA0(I)=AA0(I)+zd(i,kk)*EDT(I)*DZ*(grav/(cpdry*T_cup(I,KK)))* & ((hcd(i,kk)-hes_cup(i,kk))/(1.+GAMMA_cup(i,kk))) endif enddo diff --git a/BRAMS/src/oldgrell/cup_env.f90 b/BRAMS/src/oldgrell/cup_env.f90 index d1f76cf82..914e90cb5 100644 --- a/BRAMS/src/oldgrell/cup_env.f90 +++ b/BRAMS/src/oldgrell/cup_env.f90 @@ -2,7 +2,7 @@ subroutine cup_env(j,z,qes,he,hes,t,q,p,z1,mix,mgmxp,mkx,mgmzp,istart,iend & ,psur,ierr,tcrit,itest) - use rconstants, only : rdry, cp, alvl, aklv, akiv, ep, grav, rocp + use rconstants, only : rdry, cpdry, alvl3, aklv, akiv, ep, grav, rocp use therm_lib, only: virtt implicit none @@ -56,7 +56,7 @@ subroutine cup_env(j,z,qes,he,hes,t,q,p,z1,mix,mgmxp,mkx,mgmzp,istart,iend & do k=1,mkx do i=istart,iend if (ierr(i).eq.0) then - z(i,k) = (he(i,k)-cp*t(i,k)-alvl*q(i,k))/grav + z(i,k) = (he(i,k)-cpdry*t(i,k)-alvl3*q(i,k))/grav z(i,k) = max(1.e-3,z(i,k)) endif enddo @@ -69,8 +69,8 @@ subroutine cup_env(j,z,qes,he,hes,t,q,p,z1,mix,mgmxp,mkx,mgmzp,istart,iend & do K=1,MKX do I=ISTART,IEND if (ierr(i).eq.0) then - if (itest.eq.0) HE(I,K) = grav*Z(I,K)+cp*T(I,K)+alvl*Q(I,K) - HES(I,K) = grav*Z(I,K)+cp*T(I,K)+alvl*QES(I,K) + if (itest.eq.0) HE(I,K) = grav*Z(I,K)+cpdry*T(I,K)+alvl3*Q(I,K) + HES(I,K) = grav*Z(I,K)+cpdry*T(I,K)+alvl3*QES(I,K) if (HE(I,K).ge.HES(I,K)) HE(I,K) = HES(I,K) @@ -86,7 +86,7 @@ subroutine cup_env_clev(j,t,qes,q,he,hes,z,p,qes_cup,q_cup,he_cup,hes_cup & ,z_cup,p_cup,gamma_cup,t_cup,psur,mix,mgmxp,mkx,mgmzp & ,istart,iend,ierr,z1) - use rconstants, only : alvl, rh2o, aklv + use rconstants, only : alvl3, rh2o, aklv implicit none integer :: i, j, k, mix, mgmxp, mkx, mgmzp, istart & @@ -109,7 +109,7 @@ subroutine cup_env_clev(j,t,qes,q,he,hes,z,p,qes_cup,q_cup,he_cup,hes_cup & p_cup(i,k) = .5*(p(i,k-1) + p(i,k)) t_cup(i,k) = .5*(t(i,k-1) + t(i,k)) - gamma_cup(i,k) =aklv*(alvl/(rh2o*t_cup(i,k)*t_cup(i,k)))*qes_cup(i,k) + gamma_cup(i,k) =aklv*(alvl3/(rh2o*t_cup(i,k)*t_cup(i,k)))*qes_cup(i,k) endif enddo enddo @@ -125,7 +125,7 @@ subroutine cup_env_clev(j,t,qes,q,he,hes,z,p,qes_cup,q_cup,he_cup,hes_cup & p_cup(i,1) = psur(i) t_cup(i,1) = t(i,1) !srf - gamma_cup(i,1) = aklv*(alvl/(rh2o*t_cup(i,1)*t_cup(i,1)))*qes_cup(i,1) + gamma_cup(i,1) = aklv*(alvl3/(rh2o*t_cup(i,1)*t_cup(i,1)))*qes_cup(i,1) endif enddo @@ -320,7 +320,7 @@ end subroutine cup_kbcon !-------------------------------------------------------------------- subroutine cup_kbcon_cin(iloop,k22,kbcon,he_cup,hes_cup,z,tmean,qes,mix,mgmxp & ,mkx,mgmzp,istart,iend,ierr,kbmax,p_cup,cap_max) - use rconstants, only : alvl,aklv,rh2o,cp,grav + use rconstants, only : alvl3,aklv,rh2o,cpdry,grav implicit none integer :: i,mix,mgmxp,mkx,mgmzp,istart,iend,iloop integer, dimension(mgmxp) :: kbcon,k22,ierr,kbmax @@ -350,8 +350,8 @@ subroutine cup_kbcon_cin(iloop,k22,kbcon,he_cup,hes_cup,z,tmean,qes,mix,mgmxp & 32 continue dh = HE_cup(I,K22(I)) - HES_cup(I,KBCON(I)) if (dh.lt. 0.) then - GAMMA = aklv*(alvl/(rh2o*(Tmean(I,K22(i))**2)))*QES(I,K22(i)) - tprim = dh/(cp*(1.+gamma)) + GAMMA = aklv*(alvl3/(rh2o*(Tmean(I,K22(i))**2)))*QES(I,K22(i)) + tprim = dh/(cpdry*(1.+gamma)) cin = cin + grav*tprim*(z(i,k22(i))-z(i,k22(i)-1))/tmean(i,k22(i)) go to 31 diff --git a/BRAMS/src/oldgrell/cup_grell2.f90 b/BRAMS/src/oldgrell/cup_grell2.f90 index 466ab2620..b94fdd105 100644 --- a/BRAMS/src/oldgrell/cup_grell2.f90 +++ b/BRAMS/src/oldgrell/cup_grell2.f90 @@ -18,7 +18,7 @@ subroutine cuparth(mynum,mgmxp,mgmyp,mgmzp,m1,m2,m3,ia,iz,ja,jz,i0,j0,maxiens,ie icoic !INTENT(IN) use mem_scratch2_grell - use rconstants, only: rdry, cp, rh2o, p00, t00, grav, cpor, pi1,onerad + use rconstants, only: rdry, cpdry, rh2o, p00, t00, grav, cpor, pi1,onerad !srf mgmxp, mgmyp, mgmzp sao usadas alocar memoria para as ! variaveis da parametrizacao do Grell. @@ -148,17 +148,17 @@ subroutine cuparth(mynum,mgmxp,mgmyp,mgmzp,m1,m2,m3,ia,iz,ja,jz,i0,j0,maxiens,ie do i = istart,iend ter11(i)= ht(i,j) - psur(i) = .5*( ((pp(1,i,j)+pi0(1,i,j))/cp)**cpor*p00 + & - ((pp(2,i,j)+pi0(2,i,j))/cp)**cpor*p00 )*1.e-2 + psur(i) = .5*( ((pp(1,i,j)+pi0(1,i,j))/cpdry)**cpor*p00 + & + ((pp(2,i,j)+pi0(2,i,j))/cpdry)**cpor*p00 )*1.e-2 ! Pressure in mbar - po(i,k) = ((pp(kr,i,j)+pi0(kr,i,j))/cp)**cpor*p00*1.e-2 + po(i,k) = ((pp(kr,i,j)+pi0(kr,i,j))/cpdry)**cpor*p00*1.e-2 ! Pressure in mbar us_grell(i,k) = .5*( ua(kr,i,j) + ua(kr,i-1,j) ) vs_grell(i,k) = .5*( va(kr,i,j) + va(kr,i,j-1) ) omeg(i,k) = -grav*dn0(kr,i,j)*.5*( wa(kr,i,j)+wa(kr-1,i,j) ) - t(i,k) = theta(kr,i,j)*(pp(kr,i,j)+pi0(kr,i,j))/cp + t(i,k) = theta(kr,i,j)*(pp(kr,i,j)+pi0(kr,i,j))/cpdry q(i,k) = rv(kr,i,j) !variables for PBL top height pblidx(i) = kpbl(i,j) @@ -174,7 +174,7 @@ subroutine cuparth(mynum,mgmxp,mgmyp,mgmzp,m1,m2,m3,ia,iz,ja,jz,i0,j0,maxiens,ie ! assumindo PT(KR,I,J) << exner*THT(KR,I,J)/theta ! Temperatura projetada se a conveccao nao ocorrer - tn(i,k) = t(i,k) + ( cpdtdt/cp )*dtime + tn(i,k) = t(i,k) + ( cpdtdt/cpdry )*dtime ! Umidade projetada se a conveccao nao ocorrer qo(i,k) = q(i,k) + rtt(kr,i,j)*dtime @@ -270,7 +270,7 @@ subroutine cuparth(mynum,mgmxp,mgmyp,mgmzp,m1,m2,m3,ia,iz,ja,jz,i0,j0,maxiens,ie ! assumindo dPi/dt (=pt(kr,i,j)) << (exner/theta)*dTheta/dt: ! Exner's function = pp(kr,i,j)+pi0(kr,i,j) exner = pp(kr,i,j) + pi0(kr,i,j) - outtem(kr,i,j) = cp/exner * outt(i,k) + outtem(kr,i,j) = cpdry/exner * outt(i,k) ! tendencia do Theta devida aos cumulus outrt(kr,i,j) = outq(i,k) + outqc(i,k) ! tendencia do Rtotal devida aos cumulus @@ -337,7 +337,7 @@ subroutine cup_enss(mynum, m1, m2, m3, i0, j0, & ! USE Modules for Grell Parameterization use mem_scratch3_grell - use rconstants, only: grav, day_sec,alvl,cp + use rconstants, only: grav, day_sec,alvl3,cpdry implicit none integer maxiens,maxens,maxens2,maxens3,ensdim @@ -874,7 +874,7 @@ subroutine cup_enss(mynum, m1, m2, m3, i0, j0, & if (ierr(i).eq.0) then XHE(I,K) = DELLAH(I,K)*MBDT + HEO(I,K) XQ(I,K) = DELLAQ(I,K)*MBDT + QO(I,K) - DELLAT(I,K)= (1./cp)*(DELLAH(I,K)-alvl*DELLAQ(I,K)) + DELLAT(I,K)= (1./cpdry)*(DELLAH(I,K)-alvl3*DELLAQ(I,K)) XT_Grell(I,K) = DELLAT(I,K)*MBDT + TN(I,K) if (XQ(I,K).le.0.) XQ(I,K)=1.E-08 endif diff --git a/BRAMS/src/oldgrell/cup_grell2_shcu.f90 b/BRAMS/src/oldgrell/cup_grell2_shcu.f90 index 5dcba14bf..32fa22ce1 100644 --- a/BRAMS/src/oldgrell/cup_grell2_shcu.f90 +++ b/BRAMS/src/oldgrell/cup_grell2_shcu.f90 @@ -17,7 +17,7 @@ subroutine CUPARTH_shal(mynum,mgmxp,mgmyp,mgmzp,m1,m2,m3,ia,iz,ja,jz,i0,j0 ensdim=>ensdim_sh, & !INTENT(IN) icoic=>icoic_sh !INTENT(IN) - use rconstants, only: rdry,cp,rh2o,p00,t00,grav,cpor + use rconstants, only: rdry,cpdry,rh2o,p00,t00,grav,cpor use mem_scratch2_grell_sh @@ -90,13 +90,13 @@ subroutine CUPARTH_shal(mynum,mgmxp,mgmyp,mgmzp,m1,m2,m3,ia,iz,ja,jz,i0,j0 kr = K + 1 ! nivel K da grade DO Grell corresponde ao nivel K + 1 DO RAMS do I = ISTART,IEND z1(I)= topo(i,j) - PSUR(I) = .5*( ((pp(1,i,j)+pi0(1,i,j))/cp)**cpor*p00 + & - ((pp(2,i,j)+pi0(2,i,j))/cp)**cpor*p00 )*1.e-2 ! Pressure in mbar - PO(I,K) = ((pp(kr,i,j)+pi0(kr,i,j))/cp)**cpor*p00*1.e-2 ! Pressure in mbar + PSUR(I) = .5*( ((pp(1,i,j)+pi0(1,i,j))/cpdry)**cpor*p00 + & + ((pp(2,i,j)+pi0(2,i,j))/cpdry)**cpor*p00 )*1.e-2 ! Pressure in mbar + PO(I,K) = ((pp(kr,i,j)+pi0(kr,i,j))/cpdry)**cpor*p00*1.e-2 ! Pressure in mbar US(I,K) = .5*( ua(kr,i,j) + ua(kr,i-1,j) ) VS(I,K) = .5*( va(kr,i,j) + va(kr,i,j-1) ) OMEG(I,K) = -grav*dn0(kr,i,j)*.5*( wa(kr,i,j)+wa(kr-1,i,j) ) - T(I,K) = theta(kr,i,j)*(pp(kr,i,j)+pi0(kr,i,j))/cp + T(I,K) = theta(kr,i,j)*(pp(kr,i,j)+pi0(kr,i,j))/cpdry Q(I,K) = rv(kr,i,j) !variables for PBL top height PBLIDX(I) = KPBL(i,j) @@ -108,7 +108,7 @@ subroutine CUPARTH_shal(mynum,mgmxp,mgmyp,mgmzp,m1,m2,m3,ia,iz,ja,jz,i0,j0 !cpdTdt= exner*tht(kr,i,j) + theta(kr,i,j)*pt(kr,i,j) cpdTdt = exner*tht(kr,i,j) !assuminDO PT(KR,I,J) << exner*THT(KR,I,J)/theta !Temperatura projetada se a conveccao nao ocorrer - TN(I,K) = T(I,K) + ( cpdTdt/cp )*dtime + TN(I,K) = T(I,K) + ( cpdTdt/cpdry )*dtime !Umidade projetada se a conveccao nao ocorrer QO(I,K) = Q(I,K) + rtt(kr,i,j)*dtime !Atribuicoes DO eschema @@ -150,12 +150,12 @@ subroutine CUPARTH_shal(mynum,mgmxp,mgmyp,mgmzp,m1,m2,m3,ia,iz,ja,jz,i0,j0 kr = K + 1 do I = ISTART,IEND ! Converte tendencia da temperatura (OUTT) em tendencia de theta (OUTTEM) - ! cp*T=Pi*Theta => cp dT/dt = Theta*dPi/dt + Pi*dTheta/dt, + ! cp*T=Pi*Theta => cpdry dT/dt = Theta*dPi/dt + Pi*dTheta/dt, ! assuminDO dPi/dt (=pt(kr,i,j)) << (exner/theta)*dTheta/dt: ! Exner's function = pp(kr,i,j)+pi0(kr,i,j) exner = pp(kr,i,j) + pi0(kr,i,j) ! - outtem(kr,i,j) = CP/exner * OUTT(I,K) ! tendencia DO Theta devida aos cumulus + outtem(kr,i,j) = CPdry/exner * OUTT(I,K) ! tendencia DO Theta devida aos cumulus outrt(kr,i,j) = OUTQ(I,K) ! tendencia DO Rtotal devida aos cumulus ! enddo @@ -189,7 +189,7 @@ subroutine CUP_enss_shal(mynum,m1,m2,m3,i0, & ! use mem_scratch3_grell_sh - use rconstants, only: grav,cpi,alvl + use rconstants, only: grav,cpdryi,alvl3 implicit none integer mynum,i0,j0,m1,m2,m3 @@ -415,7 +415,7 @@ subroutine CUP_enss_shal(mynum,m1,m2,m3,i0, & ! if(ierr(i).eq.0)then XHE(I,K) = DELLAH(I,K)*MBDT + HEO(I,K) XQ(I,K) = DELLAQ(I,K)*MBDT + QO(I,K) - DELLAT(I,K) = cpi*(DELLAH(I,K)-alvl*DELLAQ(I,K)) + DELLAT(I,K) = cpdryi*(DELLAH(I,K)-alvl3*DELLAQ(I,K)) XT(I,K) = DELLAT(I,K)*MBDT + TN(I,K) if(XQ(I,K).le.0.)XQ(I,K)=1.E-08 diff --git a/BRAMS/src/oldgrell/cup_up.f90 b/BRAMS/src/oldgrell/cup_up.f90 index e698432ad..447164435 100644 --- a/BRAMS/src/oldgrell/cup_up.f90 +++ b/BRAMS/src/oldgrell/cup_up.f90 @@ -55,7 +55,7 @@ end subroutine cup_up_he subroutine cup_up_moisture(ierr,z_cup,qc,qrc,pw,pwav,kbcon,ktop,mix,mgmxp,mkx & ,mgmzp,istart,iend,cd,dby,mentr_rate,q,GAMMA_cup,zu & ,qes_cup,k22,qe_cup) - use rconstants, only : alvl + use rconstants, only : alvl3 implicit none ! cd= detrainment function ! q = environmental q on model levels @@ -119,7 +119,7 @@ subroutine cup_up_moisture(ierr,z_cup,qc,qrc,pw,pwav,kbcon,ktop,mix,mgmxp,mkx & DZ*Q(i,K-1))/(1.+mentr_rate*DZ-.5*cd(i,k)*dz) !--- Saturation in cloud, this is what is allowed to be in it - QRCH=QES_cup(I,K)+(1./alvl)*(GAMMA_cup(i,k)/(1.+GAMMA_cup(i,k)))*DBY(I,K) + QRCH=QES_cup(I,K)+(1./alvl3)*(GAMMA_cup(i,k)/(1.+GAMMA_cup(i,k)))*DBY(I,K) !--- Liquid water content in cloud after rainout QRC(I,K)=(QC(I,K)-QRCH)/(1.+C0*DZ) @@ -182,7 +182,7 @@ end subroutine cup_up_nms !---------------------------------------------------------------------- subroutine cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup,kbcon,ktop,mix,mgmxp,mkx & ,mgmzp,istart,iend,ierr) - use rconstants, only : grav, cp + use rconstants, only : grav, cpdry implicit none integer :: i,k,mix,mgmxp,mkx,mgmzp,istart,iend integer, dimension(mgmxp) :: kbcon,ktop,ierr @@ -198,7 +198,7 @@ subroutine cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup,kbcon,ktop,mix,mgmxp,mkx & if (K.le.KBCON(I)) cycle if (K.gt.KTOP(I)) cycle DZ = Z(I,K)-Z(I,K-1) - da = zu(i,k)*DZ*(grav/(cp*((T_cup(I,K)))))*DBY(I,K-1)/ & + da = zu(i,k)*DZ*(grav/(cpdry*((T_cup(I,K)))))*DBY(I,K-1)/ & (1.+GAMMA_CUP(I,K)) if (K.eq.KTOP(I).and.da.le.0.) cycle AA0(I)=AA0(I)+da diff --git a/BRAMS/src/oldgrell/mem_scratch1_grell.f90 b/BRAMS/src/oldgrell/mem_scratch1_grell.f90 index 575eb2f7d..cd4265e82 100644 --- a/BRAMS/src/oldgrell/mem_scratch1_grell.f90 +++ b/BRAMS/src/oldgrell/mem_scratch1_grell.f90 @@ -118,35 +118,35 @@ subroutine nullify_scratch1_grell(sc1_grell) implicit none type (scratch1_grell_vars) :: sc1_grell - if(associated(sc1_grell%thetasta )) nullify(sc1_grell%thetasta ) - if(associated(sc1_grell%rvsta )) nullify(sc1_grell%rvsta ) - - if(associated(sc1_grell%ierr4d )) nullify(sc1_grell%ierr4d ) - if(associated(sc1_grell%jmin4d )) nullify(sc1_grell%jmin4d ) - if(associated(sc1_grell%kdet4d )) nullify(sc1_grell%kdet4d ) - if(associated(sc1_grell%k224d )) nullify(sc1_grell%k224d ) - if(associated(sc1_grell%kbcon4d )) nullify(sc1_grell%kbcon4d ) - if(associated(sc1_grell%ktop4d )) nullify(sc1_grell%ktop4d ) - if(associated(sc1_grell%kstabi4d )) nullify(sc1_grell%kstabi4d ) - if(associated(sc1_grell%kstabm4d )) nullify(sc1_grell%kstabm4d ) - if(associated(sc1_grell%kpbl4d )) nullify(sc1_grell%kpbl4d ) - - if(associated(sc1_grell%xmb4d )) nullify(sc1_grell%xmb4d ) - if(associated(sc1_grell%edt4d )) nullify(sc1_grell%edt4d ) - - if(associated(sc1_grell%zcup5d )) nullify(sc1_grell%zcup5d ) - if(associated(sc1_grell%pcup5d )) nullify(sc1_grell%pcup5d ) - if(associated(sc1_grell%prup5d )) nullify(sc1_grell%prup5d ) - if(associated(sc1_grell%clwup5d )) nullify(sc1_grell%clwup5d ) - if(associated(sc1_grell%tup5d )) nullify(sc1_grell%tup5d ) - if(associated(sc1_grell%p_lw5d )) nullify(sc1_grell%p_lw5d ) - - if(associated(sc1_grell%enup5d )) nullify(sc1_grell%enup5d ) - if(associated(sc1_grell%endn5d )) nullify(sc1_grell%endn5d ) - if(associated(sc1_grell%deup5d )) nullify(sc1_grell%deup5d ) - if(associated(sc1_grell%dedn5d )) nullify(sc1_grell%dedn5d ) - if(associated(sc1_grell%zup5d )) nullify(sc1_grell%zup5d ) - if(associated(sc1_grell%zdn5d )) nullify(sc1_grell%zdn5d ) + nullify(sc1_grell%thetasta ) + nullify(sc1_grell%rvsta ) + + nullify(sc1_grell%ierr4d ) + nullify(sc1_grell%jmin4d ) + nullify(sc1_grell%kdet4d ) + nullify(sc1_grell%k224d ) + nullify(sc1_grell%kbcon4d ) + nullify(sc1_grell%ktop4d ) + nullify(sc1_grell%kstabi4d ) + nullify(sc1_grell%kstabm4d ) + nullify(sc1_grell%kpbl4d ) + + nullify(sc1_grell%xmb4d ) + nullify(sc1_grell%edt4d ) + + nullify(sc1_grell%zcup5d ) + nullify(sc1_grell%pcup5d ) + nullify(sc1_grell%prup5d ) + nullify(sc1_grell%clwup5d ) + nullify(sc1_grell%tup5d ) + nullify(sc1_grell%p_lw5d ) + + nullify(sc1_grell%enup5d ) + nullify(sc1_grell%endn5d ) + nullify(sc1_grell%deup5d ) + nullify(sc1_grell%dedn5d ) + nullify(sc1_grell%zup5d ) + nullify(sc1_grell%zdn5d ) return end subroutine nullify_scratch1_grell diff --git a/BRAMS/src/oldgrell/old_grell_cupar_driver.f90 b/BRAMS/src/oldgrell/old_grell_cupar_driver.f90 index 218b49088..7f54471c2 100644 --- a/BRAMS/src/oldgrell/old_grell_cupar_driver.f90 +++ b/BRAMS/src/oldgrell/old_grell_cupar_driver.f90 @@ -224,8 +224,7 @@ end subroutine old_grell_cupar_driver !==========================================================================================! subroutine include_shal_effect(m1,m2,m3,ia,iz,ja,jz,dtlt & ,thetasta,rvsta,theta,rv,pi0,pp,thsrc,rtsrc) - use therm_lib , only : rslf - use rconstants, only : cpi,cpor,p00 + use therm_lib , only : rslf,exner2press,extheta2temp implicit none integer, intent(in) :: ia,iz,ja,jz integer, intent(in) :: m1,m2,m3 @@ -234,15 +233,16 @@ subroutine include_shal_effect(m1,m2,m3,ia,iz,ja,jz,dtlt real , intent(in) , dimension(m1,m2,m3) :: theta,rv,pi0,pp real , intent(in) , dimension(m1,m2,m3) :: thsrc,rtsrc integer :: i,j,k - real :: press,rsat,tempk + real :: exner,press,rsat,tempk do j=ja,jz do i=ia,iz do k=2,m1 ! Updating the potential temperature thetasta(k,i,j) = theta(k,i,j)+dtlt*thsrc(k,i,j) ! Finding the vapour mixing ratio after the shallow cumulus call - press=p00*(cpi*(pi0(k,i,j)+pp(k,i,j)))**cpor - tempk=cpi*theta(k,i,j)*(pi0(k,i,j)+pp(k,i,j)) + exner=pi0(k,i,j)+pp(k,i,j) + press=exner2press(exner) + tempk=extheta2temp(exner,theta(k,i,j)) rsat =rslf(press,tempk) rvsta(k,i,j) = max(epsilon(1.),min(rsat,rv(k,i,j)+dtlt*rtsrc(k,i,j))) diff --git a/BRAMS/src/radiate/harr_rad.F90 b/BRAMS/src/radiate/harr_rad.F90 index 5ce017d84..6fa2343af 100644 --- a/BRAMS/src/radiate/harr_rad.F90 +++ b/BRAMS/src/radiate/harr_rad.F90 @@ -52,7 +52,6 @@ !------------------------------------------------------------------------------------------! subroutine harr_swrad(nz,alb,amu0,time,mynum) - use rconstants , only : cp ! ! intent(in) use mem_harr , only : mb & ! intent(in) , mg & ! intent(in) , mk & ! intent(in) @@ -412,7 +411,6 @@ end subroutine harr_swrad !------------------------------------------------------------------------------------------! subroutine harr_lwrad(nz,mynum) - use rconstants , only : cp ! ! intent(in) use mem_harr , only : mb & ! intent(in) , mg & ! intent(in) , mk & ! intent(in) diff --git a/BRAMS/src/radiate/harr_raddriv.f90 b/BRAMS/src/radiate/harr_raddriv.f90 index b2d10044f..4b1a733d8 100644 --- a/BRAMS/src/radiate/harr_raddriv.f90 +++ b/BRAMS/src/radiate/harr_raddriv.f90 @@ -57,48 +57,132 @@ subroutine harr_raddriv(m1,m2,m3,nclouds,ncrad,ifm,if_adap,time,deltat,ia,iz,ja, ,con_c,con_r,con_p,con_s,con_a,con_g,con_h & ,cuprliq,cuprice,cuparea,cupierr,mynum) - use mem_harr, only: mg, mb, mpb - use mem_grid, only: zm, zt - use rconstants, only: cpor, p00i, stefan, cp, cpi, p00, hr_sec, toodry - use micphys, only: ncat,rxmin - use mem_leaf, only: isfcl - use mem_radiate, only: rad_cosz_min - use harr_coms, only: rl,dzl,dl,pl,co2l,o3l,vp,u,tp,omgp,gp,zml,ztl,tl & - ,flxus,flxds,flxul,flxdl,fu,fd,zero_harr_met_scratch & - ,zero_harr_flx_scratch,nradmax,tairk,rhoi,rhoe,rhov,press & - ,rcl_parm,rpl_parm,area_parm,flx_diff - + use mem_harr , only : mg & ! intent(in) + , mb & ! intent(in) + , mpb ! ! intent(in) + use mem_grid , only : zm & ! intent(in) + , zt ! ! intent(in) + use rconstants , only : stefan & ! intent(in) + , cpdry & ! intent(in) + , hr_sec & ! intent(in) + , toodry ! ! intent(in) + use micphys , only : ncat & ! intent(inout) + , rxmin ! ! intent(inout) + use mem_leaf , only : isfcl ! ! intent(in) + use mem_radiate, only : rad_cosz_min ! ! intent(in) + use harr_coms , only : rl & ! intent(inout) + , dzl & ! intent(inout) + , dl & ! intent(inout) + , pl & ! intent(inout) + , co2l & ! intent(inout) + , o3l & ! intent(inout) + , vp & ! intent(inout) + , u & ! intent(inout) + , tp & ! intent(inout) + , omgp & ! intent(inout) + , gp & ! intent(inout) + , zml & ! intent(inout) + , ztl & ! intent(inout) + , tl & ! intent(inout) + , flxus & ! intent(inout) + , flxds & ! intent(inout) + , flxul & ! intent(inout) + , flxdl & ! intent(inout) + , fu & ! intent(inout) + , fd & ! intent(inout) + , zero_harr_met_scratch & ! subroutine + , zero_harr_flx_scratch & ! subroutine + , nradmax & ! intent(inout) + , tairk & ! intent(inout) + , rhoi & ! intent(inout) + , rhoe & ! intent(inout) + , rhov & ! intent(inout) + , press & ! intent(inout) + , rcl_parm & ! intent(inout) + , rpl_parm & ! intent(inout) + , area_parm & ! intent(inout) + , flx_diff ! ! intent(inout) + use therm_lib , only : exner2press & ! function + , extheta2temp ! ! function implicit none !----- Arguments -----------------------------------------------------------------------! - integer , intent(in) :: m1,m2,m3,nclouds,ncrad - integer , intent(in) :: mynum,ifm,if_adap - integer , intent(in) :: ia,iz,ja,jz - integer , intent(in) :: nadd_rad,iswrtyp,ilwrtyp,icumfdbk - real(kind=8) , intent(in) :: time - real , intent(in) :: deltat - real, dimension(m2,m3) , intent(in) :: topt,glon,glat,flpw,rtgt - real, dimension(m1,m2,m3) , intent(in) :: pi0,pp,rho,theta,rv,co2p - real, dimension(m1,m2,m3) , intent(in) :: sh_c,sh_r,sh_p,sh_s,sh_a,sh_g,sh_h - real, dimension(m1,m2,m3) , intent(in) :: con_c,con_r,con_p,con_s,con_a - real, dimension(m1,m2,m3) , intent(in) :: con_g,con_h - real, dimension(m2,m3,nclouds) , intent(in) :: cuparea - real, dimension(m2,m3,nclouds) , intent(in) :: cupierr - real, dimension(m1,m2,m3,nclouds) , intent(in) :: cuprliq - real, dimension(m1,m2,m3,nclouds) , intent(in) :: cuprice - real, dimension(m2,m3) , intent(inout) :: rshort,rlong,rlongup,cosz,albedt - real, dimension(m2,m3) , intent(inout) :: rshort_top,rshortup_top - real, dimension(m2,m3) , intent(inout) :: rshort_diffuse - real, dimension(m2,m3) , intent(inout) :: rlongup_top - real, dimension(m1,m2,m3) , intent(inout) :: fthrd,fthrd_lw + integer , intent(in) :: m1 + integer , intent(in) :: m2 + integer , intent(in) :: m3 + integer , intent(in) :: nclouds + integer , intent(in) :: ncrad + integer , intent(in) :: mynum + integer , intent(in) :: ifm + integer , intent(in) :: if_adap + integer , intent(in) :: ia + integer , intent(in) :: iz + integer , intent(in) :: ja + integer , intent(in) :: jz + integer , intent(in) :: nadd_rad + integer , intent(in) :: iswrtyp + integer , intent(in) :: ilwrtyp + integer , intent(in) :: icumfdbk + real(kind=8) , intent(in) :: time + real(kind=4) , intent(in) :: deltat + real(kind=4), dimension(m2,m3) , intent(in) :: topt + real(kind=4), dimension(m2,m3) , intent(in) :: glon + real(kind=4), dimension(m2,m3) , intent(in) :: glat + real(kind=4), dimension(m2,m3) , intent(in) :: flpw + real(kind=4), dimension(m2,m3) , intent(in) :: rtgt + real(kind=4), dimension(m1,m2,m3) , intent(in) :: pi0 + real(kind=4), dimension(m1,m2,m3) , intent(in) :: pp + real(kind=4), dimension(m1,m2,m3) , intent(in) :: rho + real(kind=4), dimension(m1,m2,m3) , intent(in) :: theta + real(kind=4), dimension(m1,m2,m3) , intent(in) :: rv + real(kind=4), dimension(m1,m2,m3) , intent(in) :: co2p + real(kind=4), dimension(m1,m2,m3) , intent(in) :: sh_c + real(kind=4), dimension(m1,m2,m3) , intent(in) :: sh_r + real(kind=4), dimension(m1,m2,m3) , intent(in) :: sh_p + real(kind=4), dimension(m1,m2,m3) , intent(in) :: sh_s + real(kind=4), dimension(m1,m2,m3) , intent(in) :: sh_a + real(kind=4), dimension(m1,m2,m3) , intent(in) :: sh_g + real(kind=4), dimension(m1,m2,m3) , intent(in) :: sh_h + real(kind=4), dimension(m1,m2,m3) , intent(in) :: con_c + real(kind=4), dimension(m1,m2,m3) , intent(in) :: con_r + real(kind=4), dimension(m1,m2,m3) , intent(in) :: con_p + real(kind=4), dimension(m1,m2,m3) , intent(in) :: con_s + real(kind=4), dimension(m1,m2,m3) , intent(in) :: con_a + real(kind=4), dimension(m1,m2,m3) , intent(in) :: con_g + real(kind=4), dimension(m1,m2,m3) , intent(in) :: con_h + real(kind=4), dimension(m2,m3,nclouds) , intent(in) :: cuparea + real(kind=4), dimension(m2,m3,nclouds) , intent(in) :: cupierr + real(kind=4), dimension(m1,m2,m3,nclouds) , intent(in) :: cuprliq + real(kind=4), dimension(m1,m2,m3,nclouds) , intent(in) :: cuprice + real(kind=4), dimension(m2,m3) , intent(inout) :: rshort + real(kind=4), dimension(m2,m3) , intent(inout) :: rlong + real(kind=4), dimension(m2,m3) , intent(inout) :: rlongup + real(kind=4), dimension(m2,m3) , intent(inout) :: cosz + real(kind=4), dimension(m2,m3) , intent(inout) :: albedt + real(kind=4), dimension(m2,m3) , intent(inout) :: rshort_top + real(kind=4), dimension(m2,m3) , intent(inout) :: rshortup_top + real(kind=4), dimension(m2,m3) , intent(inout) :: rshort_diffuse + real(kind=4), dimension(m2,m3) , intent(inout) :: rlongup_top + real(kind=4), dimension(m1,m2,m3) , intent(inout) :: fthrd + real(kind=4), dimension(m1,m2,m3) , intent(inout) :: fthrd_lw !------ Local arrays -------------------------------------------------------------------! - integer :: ka - integer :: nrad - integer :: koff - integer :: icld - integer :: i,j,k,ib,ig,kk,ik,krad,mcat - real :: area_csky + integer :: ka + integer :: nrad + integer :: koff + integer :: icld + integer :: i + integer :: j + integer :: k + integer :: ib + integer :: ig + integer :: kk + integer :: ik + integer :: krad + integer :: mcat + real(kind=4) :: area_csky + real(kind=4) :: exner !---------------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------------! ! Copy surface and vertical-column values from model to radiation memory space. In ! ! this loop, (k-koff) ranges from 2 to m1 + 1 - nint(flpw(i,j)). ! @@ -115,11 +199,12 @@ subroutine harr_raddriv(m1,m2,m3,nclouds,ncrad,ifm,if_adap,time,deltat,ia,iz,ja, do k = ka,m1-1 - tairk(k) = theta(k,i,j) * (pi0(k,i,j)+pp(k,i,j)) * cpi + exner = pi0(k,i,j)+pp(k,i,j) + tairk(k) = extheta2temp(exner,theta(k,i,j)) rhoe(k) = rho(k,i,j) rhov(k) = max(toodry,rv(k,i,j)) * rhoe(k) rhoi(k) = 1./rho(k,i,j) - press(k) = p00 * (cpi * (pi0(k,i,j)+pp(k,i,j)) ) ** cpor + press(k) = exner2press(exner) dl(k-koff) = rho(k,i,j) pl(k-koff) = press(k) tl(k-koff) = tairk(k) @@ -259,7 +344,7 @@ subroutine harr_raddriv(m1,m2,m3,nclouds,ncrad,ifm,if_adap,time,deltat,ia,iz,ja, fthrd(k,i,j) = fthrd(k,i,j) & + ( (flxds(krad)-flxds(krad-1) & + flxus(krad-1)-flxus(krad)) & - / (dl(krad) * dzl(krad) * cp)) * area_parm + / (dl(krad) * dzl(krad) * cpdry)) * area_parm end do end if end if @@ -279,11 +364,11 @@ subroutine harr_raddriv(m1,m2,m3,nclouds,ncrad,ifm,if_adap,time,deltat,ia,iz,ja, fthrd(k,i,j) = fthrd(k,i,j) & + ( (flxdl(krad)-flxdl(krad-1) & + flxul(krad-1)-flxul(krad)) & - / (dl(krad) * dzl(krad) * cp)) * area_parm + / (dl(krad) * dzl(krad) * cpdry)) * area_parm fthrd_lw(k,i,j) = fthrd_lw(k,i,j) & + ( (flxdl(krad)-flxdl(krad-1) & + flxul(krad-1)-flxul(krad)) & - / (dl(krad) * dzl(krad) * cp)) * area_parm + / (dl(krad) * dzl(krad) * cpdry)) * area_parm end do end if end do cldloop @@ -632,9 +717,7 @@ subroutine cloud_opt(m1,ka,nrad,koff,mcat,icld,time,mynum) , jhabtab & ! intent(in) , parm & ! intent(in) , availcat ! ! intent(in) - use rconstants , only : p00i & ! intent(in) - , rocp & ! intent(in) - , hr_sec & ! intent(in) + use rconstants , only : hr_sec & ! intent(in) , lnexp_min ! ! intent(in) use harr_coms , only : jhcatharr & ! intent(in) ,dzl & ! intent(in) diff --git a/BRAMS/src/radiate/mem_carma.f90 b/BRAMS/src/radiate/mem_carma.f90 index b6f439d47..59dc7e1c5 100644 --- a/BRAMS/src/radiate/mem_carma.f90 +++ b/BRAMS/src/radiate/mem_carma.f90 @@ -148,17 +148,16 @@ module mem_carma !=======================================================================================! !=======================================================================================! - subroutine alloc_carma(car,ng,nmxp,nmyp,nw) + subroutine alloc_carma(car,nmxp,nmyp,nw) implicit none !----- Arguments. -------------------------------------------------------------------! - type (carma_v), dimension(:), intent(inout) :: car - integer , intent(in) :: ng - integer , intent(in) :: nw - integer , intent(in) :: nmxp - integer , intent(in) :: nmyp + type (carma_v), intent(inout) :: car + integer , intent(in) :: nw + integer , intent(in) :: nmxp + integer , intent(in) :: nmyp !------------------------------------------------------------------------------------! - allocate (car(ng)%aot(nmxp,nmyp,nw)) + allocate (car%aot(nmxp,nmyp,nw)) return end subroutine alloc_carma @@ -172,14 +171,13 @@ end subroutine alloc_carma !=======================================================================================! !=======================================================================================! - subroutine nullify_carma(car,ng) + subroutine nullify_carma(car) implicit none !----- Arguments. -------------------------------------------------------------------! - type (carma_v), dimension(:), intent(inout) :: car - integer , intent(in) :: ng + type (carma_v), intent(inout) :: car !------------------------------------------------------------------------------------! - if (associated(car(ng)%aot )) nullify (car(ng)%aot ) + nullify (car%aot) return @@ -194,14 +192,13 @@ end subroutine nullify_carma !=======================================================================================! !=======================================================================================! - subroutine dealloc_carma(car,ng) + subroutine dealloc_carma(car) implicit none !----- Arguments. -------------------------------------------------------------------! - type (carma_v), dimension(:), intent(inout) :: car - integer , intent(in) :: ng + type (carma_v), intent(inout) :: car !------------------------------------------------------------------------------------! - if (associated(car(ng)%aot )) deallocate (car(ng)%aot ) + if (associated(car%aot)) deallocate (car%aot) return end subroutine dealloc_carma @@ -215,14 +212,13 @@ end subroutine dealloc_carma !=======================================================================================! !=======================================================================================! - subroutine zero_carma(car,ng) + subroutine zero_carma(car) implicit none !----- Arguments. -------------------------------------------------------------------! - type (carma_v), dimension(:), intent(inout) :: car - integer , intent(in) :: ng + type (carma_v), intent(inout) :: car !------------------------------------------------------------------------------------! - if (associated(car(ng)%aot )) car(ng)%aot(:,:,:)=0. + if (associated(car%aot )) car%aot(:,:,:) = 0. return end subroutine zero_carma @@ -248,14 +244,12 @@ subroutine filltab_carma(cv,cvm,ng,imean,nmx,nmy,nmwave) integer , intent(in) :: imean !----- Local variables. -------------------------------------------------------------! integer :: npts - character(len=7) :: sname !------------------------------------------------------------------------------------! if (associated(cv%aot)) then npts=nmx*nmy*nmwave - write(sname,fmt='(a4)') 'AOT' call vtables2(cv%aot,cvm%aot,ng,npts,imean & - ,sname//' :7:hist:anal:mpti:mpt3') + ,'AOT :7:hist:anal:mpti:mpt3') end if return end subroutine filltab_carma diff --git a/BRAMS/src/radiate/mem_radiate.f90 b/BRAMS/src/radiate/mem_radiate.f90 index 8b2e4d806..711b569f7 100644 --- a/BRAMS/src/radiate/mem_radiate.f90 +++ b/BRAMS/src/radiate/mem_radiate.f90 @@ -113,17 +113,17 @@ subroutine nullify_radiate(radiate) type (radiate_vars), intent(inout) :: radiate !------------------------------------------------------------------------------------! - if (associated(radiate%fthrd )) nullify (radiate%fthrd ) - if (associated(radiate%rshort )) nullify (radiate%rshort ) - if (associated(radiate%rlong )) nullify (radiate%rlong ) - if (associated(radiate%rlongup )) nullify (radiate%rlongup ) - if (associated(radiate%albedt )) nullify (radiate%albedt ) - if (associated(radiate%cosz )) nullify (radiate%cosz ) - if (associated(radiate%fthrd_lw )) nullify (radiate%fthrd_lw ) - if (associated(radiate%rshort_top )) nullify (radiate%rshort_top ) - if (associated(radiate%rshortup_top )) nullify (radiate%rshortup_top ) - if (associated(radiate%rlongup_top )) nullify (radiate%rlongup_top ) - if (associated(radiate%rshort_diffuse)) nullify (radiate%rshort_diffuse) + nullify (radiate%fthrd ) + nullify (radiate%rshort ) + nullify (radiate%rlong ) + nullify (radiate%rlongup ) + nullify (radiate%albedt ) + nullify (radiate%cosz ) + nullify (radiate%fthrd_lw ) + nullify (radiate%rshort_top ) + nullify (radiate%rshortup_top ) + nullify (radiate%rlongup_top ) + nullify (radiate%rshort_diffuse) return end subroutine nullify_radiate diff --git a/BRAMS/src/radiate/rad_carma.f90 b/BRAMS/src/radiate/rad_carma.f90 index 3aed3882f..fc73d34bf 100644 --- a/BRAMS/src/radiate/rad_carma.f90 +++ b/BRAMS/src/radiate/rad_carma.f90 @@ -29,11 +29,9 @@ subroutine radcomp_carma(m1,m2,m3,npat,nclouds,ncrad,ia,iz,ja,jz,mynum,iswrtyp,i use mem_aerad , only : nwave ! ! intent(in) use mem_radiate , only : rad_cosz_min ! ! intent(in) use rconstants , only : day_sec & ! intent(in) - , p00 & ! intent(in) - , t00 & ! intent(in) - , cpor & ! intent(in) - , cpi ! ! intent(in) - + , t00 ! ! intent(in) + use therm_lib , only : exner2press & ! function + , extheta2temp ! ! function implicit none !----- Arguments. -------------------------------------------------------------------! integer , intent(in) :: m1 @@ -101,6 +99,7 @@ subroutine radcomp_carma(m1,m2,m3,npat,nclouds,ncrad,ia,iz,ja,jz,mynum,iswrtyp,i real, dimension(m1) :: fthrd_cld real, dimension(nwave) :: aotl_cld real, dimension(nwave) :: aotl + real :: exner real :: press real :: tempc real :: rvcgs @@ -253,8 +252,9 @@ subroutine radcomp_carma(m1,m2,m3,npat,nclouds,ncrad,ia,iz,ja,jz,mynum,iswrtyp,i ,'FTHRD [K/day]' write (unit=*,fmt='(123a)') ('-',k=1,123) do k=1,m1 - press = ((pp(k,i,j) + pi0(k,i,j)) * cpi) ** cpor * p00 * 0.01 - tempc = (theta(k,i,j) * (pp(k,i,j) + pi0(k,i,j)) * cpi) - t00 + exner = pp(k,i,j) + pi0(k,i,j) + press = exner2press(exner) * 0.01 + tempc = extheta2temp(exner,theta(k,i,j)) - t00 rvcgs = rv(k,i,j) * 1000. write (unit=*,fmt='(i5,1x,8(f13.6,1x),es13.6,1x)') & k, tempc , press & @@ -307,34 +307,33 @@ end subroutine radcomp_carma subroutine radcarma(nzpmax,m1,solfac,theta,pi0,pp,rv,rain,lwl,iwl,lwl_cld,iwl_cld,dn0 & ,rtp,fthrd,rtgt,f13t,f23t,glat,glon,rshort,rshort_top,rshortup_top & ,rlong,rlongup_top,albedt,cosz,rlongup,mynum,fmapt,pm,aotl,xland) - use catt_start , only : catt ! ! intent(in) - use mem_grid , only : centlon & ! intent(in) - , dzm & ! intent(in) - , dzt & ! intent(in) - , idatea & ! intent(in) - , imontha & ! intent(in) - , itimea & ! intent(in) - , itopo & ! intent(in) - , iyeara & ! intent(in) - , ngrid & ! intent(in) - , nzp & ! intent(in) - , plonn & ! intent(in) - , time & ! intent(in) - , dtlt ! ! intent(in) - use mem_radiate , only : lonrad & ! intent(in) - , iswrtyp & ! intent(in) - , ilwrtyp ! ! intent(in) - use rconstants , only : cp & ! intent(in) - , cpor & ! intent(in) - , p00 & ! intent(in) - , pio180 & ! intent(in) - , halfpi & ! intent(in) - , wdns & ! intent(in) - , stefan & ! intent(in) - , toodry ! ! intent(in) - use mem_aerad , only : ngas & ! intent(in) - , nwave & ! intent(in) - , lprocopio ! ! intent(in) + use catt_start , only : catt ! ! intent(in) + use mem_grid , only : centlon & ! intent(in) + , dzm & ! intent(in) + , dzt & ! intent(in) + , idatea & ! intent(in) + , imontha & ! intent(in) + , itimea & ! intent(in) + , itopo & ! intent(in) + , iyeara & ! intent(in) + , ngrid & ! intent(in) + , nzp & ! intent(in) + , plonn & ! intent(in) + , time & ! intent(in) + , dtlt ! ! intent(in) + use mem_radiate , only : lonrad & ! intent(in) + , iswrtyp & ! intent(in) + , ilwrtyp ! ! intent(in) + use rconstants , only : pio180 & ! intent(in) + , halfpi & ! intent(in) + , wdns & ! intent(in) + , stefan & ! intent(in) + , toodry ! ! intent(in) + use mem_aerad , only : ngas & ! intent(in) + , nwave & ! intent(in) + , lprocopio ! ! intent(in) + use therm_lib , only : exner2press & ! function + , extheta2temp ! ! function implicit none !----- Arguments. -------------------------------------------------------------------! integer , intent(in) :: nzpmax @@ -383,7 +382,7 @@ subroutine radcarma(nzpmax,m1,solfac,theta,pi0,pp,rv,rain,lwl,iwl,lwl_cld,iwl_cl real :: xlandr real, dimension(nzpmax) :: fthrl real, dimension(nzpmax) :: fthrs - real :: pird + real :: exner real :: dzsdx real :: dzsdy real :: dlon @@ -413,12 +412,12 @@ subroutine radcarma(nzpmax,m1,solfac,theta,pi0,pp,rv,rain,lwl,iwl,lwl_cld,iwl_cl !----- Copy environment variables to some scratch arrays. ---------------------------! nzz = m1 - 1 do k = 1,m1 - pird = (pp(k) + pi0(k)) / cp - temprd(k) = theta(k) * pird ! air temperature (k) + exner = pp(k) + pi0(k) + temprd(k) = extheta2temp(exner,theta(k)) ! air temperature (k) rvr(k) = max(toodry,rv(k)) !----- Convert the next 7 variables to cgs for the time being. -------------------! - prd(k) = pird ** cpor * p00 * 10. ! pressure + prd(k) = exner2press(exner) * 10. ! pressure dn0r(k) = dn0(k) * 1.e-3 ! air density dztr(k) = dzt(k) / rtgt * 1.e-2 diff --git a/BRAMS/src/radiate/rad_ccmp.f90 b/BRAMS/src/radiate/rad_ccmp.f90 index c2a185f53..6fbc6471e 100644 --- a/BRAMS/src/radiate/rad_ccmp.f90 +++ b/BRAMS/src/radiate/rad_ccmp.f90 @@ -9,7 +9,7 @@ !«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»«»! ![MLO - Changed many things here to double precision to avoid FPE. Changed dimensions to attempt binary reproducibility. subroutine shradc(nzp,rvr,rtr,dn0r,dzzr,prd,albedo,solar,cosz,fthr,rshort) - use rconstants, only: cp + use rconstants, only: cpdry implicit none !----- List of arguments ------------------------------------------------------------------------------------------------! integer , intent(in) :: nzp @@ -20,7 +20,7 @@ subroutine shradc(nzp,rvr,rtr,dn0r,dzzr,prd,albedo,solar,cosz,fthr,rshort) !----- List of parameters -----------------------------------------------------------------------------------------------! real(kind=8), parameter :: zero=dble(0.),one=dble(1.) - real(kind=8), parameter :: cpcgs=dble(10000.)*dble(cp) + real(kind=8), parameter :: cpcgs=dble(10000.)*dble(cpdry) integer , parameter :: nzmax=200 , iiv1= 1 , iiv2= 2 , iiv3= 3 integer , parameter :: iv1= 1 , iv2= 2 , iv3= 3 , iv4= 4 , iv5= 5 & , iv6= 6 , iv7= 7 , iv8= 8 , iv9= 9 , iv10= 10 & @@ -377,7 +377,7 @@ subroutine lwradc(nzp,rvr,rtr,co2r,dn0r,temprd,prd,dzzr,fthr,rlong) ! ! FD1,FD2 ..... downwelling fluxes (1-vapor) (2-CO2) ! +-------------------------------------------------------------------- ! The subroutine uses CGS but constants are based on the global ones. - use rconstants, only : grav, cp, stefan, ep , volmoll, mmco2i + use rconstants, only : grav, cpdry, stefan, ep , volmoll, mmco2i implicit none !----- List of arguments --------------------------------------------------------------------------------! integer, intent(in) :: nzp @@ -389,7 +389,7 @@ subroutine lwradc(nzp,rvr,rtr,co2r,dn0r,temprd,prd,dzzr,fthr,rlong) real(kind=8), parameter :: gcgs=dble(grav)*100. real(kind=8), parameter :: stefancgs=1000.*dble(stefan) real(kind=8), parameter :: prefcgs=dble(1.01325e6) - real(kind=8), parameter :: cpcgs=dble(cp)*10000. + real(kind=8), parameter :: cpcgs=dble(cpdry)*10000. real(kind=8), parameter , dimension(4) :: ad=(/ 8.857, -332.8, 14607., -261900. /) real(kind=8), parameter , dimension(4) :: au=(/ 9.329, -446.4, 824., 259700. /) real(kind=8), parameter , dimension(5) :: bd=(/ .6558, .12175, 1.4976e-2, 1.4981e-3, .49e-4 /) @@ -740,7 +740,7 @@ subroutine shradp(nzp,rvr,dn0r,dzr,sc,pird,cosz,albedo & ! the ground ! ! ! !+----------------------------------------------------------------------! - use rconstants, only : cp + use rconstants, only : cpdry implicit none !----- Arguments: ------------------------------------------------------! integer, intent(in) :: nzp @@ -751,7 +751,7 @@ subroutine shradp(nzp,rvr,dn0r,dzr,sc,pird,cosz,albedo & real , intent(inout) , dimension(nzp,2) :: sc !----- List of constants -----------------------------------------------! integer, parameter :: iv1=1,iv2=2 - real, parameter :: cpcgs=10000.*cp + real, parameter :: cpcgs=10000.*cpdry integer :: nz,k real :: raysct,rdcon1,vabs @@ -819,7 +819,7 @@ subroutine lwradp(nzp,temprd,rvr,co2r,dn0r,dzzr,pird,sc,fthr,rlong) ! RLONG - downward longwave flux at the ground ! ! ! !--------------------------------------------------------------------------------------------------------------------! - use rconstants, only : grav,cp,stefan,p00,cpor + use rconstants, only : grav,cpdry,stefan,p00,cpor implicit none integer , intent(in) :: nzp real , intent(in) , dimension(nzp) :: rvr,co2r,dn0r,temprd,dzzr, pird @@ -830,7 +830,7 @@ subroutine lwradp(nzp,temprd,rvr,co2r,dn0r,dzzr,pird,sc,fthr,rlong) real , parameter :: p00cgs =10. * p00 real , parameter :: gcgs =100. * grav real , parameter :: stefancgs =1000. * stefan - real , parameter :: cpcgs =10000. * cp + real , parameter :: cpcgs =10000. * cpdry integer , parameter :: iv1= 1, iv2= 2, iv3= 3, iv4= 4, iv5= 5, iv6= 6 & , iv7= 7, iv8= 8, iv9= 9, iv10= 10, iv11= 11, iv12= 12 & , iv13= 13, iv14= 14, iv15= 15, iv16= 16, iv17= 17, iv18= 18 diff --git a/BRAMS/src/radiate/rad_driv.f90 b/BRAMS/src/radiate/rad_driv.f90 index 2fa208d1a..8d42025e6 100644 --- a/BRAMS/src/radiate/rad_driv.f90 +++ b/BRAMS/src/radiate/rad_driv.f90 @@ -52,7 +52,7 @@ subroutine radiate(mzp,mxp,myp,ia,iz,ja,jz,mynum) ,vctr12 & ! intent(inout) ,scratch ! ! intent(inout) use mem_micro , only: micro_g ! ! intent(in) - use therm_lib , only: qtk & ! subroutine + use therm_lib , only: uint2tl & ! subroutine ,level & ! intent(in) ,cloud_on & ! intent(in) ,bulk_on ! ! intent(in) @@ -157,7 +157,7 @@ subroutine radiate(mzp,mxp,myp,ia,iz,ja,jz,mynum) do i=ia,iz ka = nint(grid_g(ngrid)%flpw(i,j)) do k=ka,kz - call qtk(micro_g(ngrid)%q6(k,i,j),tcoal,fracliq) + call uint2tl(micro_g(ngrid)%q6(k,i,j),tcoal,fracliq) lwl(k,i,j) = lwl(k,i,j) + fracliq*micro_g(ngrid)%rgp(k,i,j) iwl(k,i,j) = iwl(k,i,j) + (1.-fracliq)*micro_g(ngrid)%rgp(k,i,j) end do @@ -170,7 +170,7 @@ subroutine radiate(mzp,mxp,myp,ia,iz,ja,jz,mynum) do i=ia,iz ka = nint(grid_g(ngrid)%flpw(i,j)) do k=ka,kz - call qtk(micro_g(ngrid)%q7(k,i,j),tcoal,fracliq) + call uint2tl(micro_g(ngrid)%q7(k,i,j),tcoal,fracliq) lwl(k,i,j) = lwl(k,i,j) + fracliq*micro_g(ngrid)%rhp(k,i,j) iwl(k,i,j) = iwl(k,i,j) + (1.-fracliq)*micro_g(ngrid)%rhp(k,i,j) end do @@ -491,7 +491,7 @@ subroutine radcomp(m1,m2,m3,ifm,ia,iz,ja,jz,theta,pi0,pp,rv,dn0,rtp,co2p,fthrd,r , solfac & ! intent(in) , sun_longitude & ! intent(in) , rad_cosz_min ! ! intent(in) - use rconstants , only : cpi & ! intent(in) + use rconstants , only : cpdryi & ! intent(in) , cpor & ! intent(in) , p00 & ! intent(in) , stefan & ! intent(in) @@ -531,7 +531,7 @@ subroutine radcomp(m1,m2,m3,ifm,ia,iz,ja,jz,theta,pi0,pp,rv,dn0,rtp,co2p,fthrd,r end do do k = 1,m1 !---- Compute some basic thermodynamic variables (pressure, temperature). -----! - pird(k) = (pp(k,i,j) + pi0(k,i,j)) * cpi + pird(k) = (pp(k,i,j) + pi0(k,i,j)) * cpdryi temprd(k) = theta(k,i,j) * pird(k) rvr(k) = max(0.,rv(k,i,j)) rtr(k) = max(rvr(k),rtp(k,i,j)) @@ -774,7 +774,7 @@ subroutine zen(m2,m3,ia,iz,ja,jz,iswrtyp,ilwrtyp,glon,glat,cosz) radlat=dble(glat(i,j))*pio1808 cosz(i,j) = sngl(dsin(radlat)*sdec+dcos(radlat)*cdec*dcos(hrangl)) !----- Making sure that it is bounded -----------------------------------------! - cosz(i,j) = max(-1.d0,min(1.d0,cosz(i,j))) + cosz(i,j) = max(-1.0,min(1.0,cosz(i,j))) end do end do else diff --git a/BRAMS/src/soil_moisture/soil_moisture_init.f90 b/BRAMS/src/soil_moisture/soil_moisture_init.f90 index 4325c3767..190deaf06 100644 --- a/BRAMS/src/soil_moisture/soil_moisture_init.f90 +++ b/BRAMS/src/soil_moisture/soil_moisture_init.f90 @@ -21,13 +21,7 @@ subroutine soil_moisture_init(n1,n2,n3,mzg,npat,ifm,can_theta,can_prss,glat,glon , oslmsts & ! intent(in) , osoilcp ! ! intent(in) use io_params , only : timstr ! ! intent(in) - use rconstants , only : cpi & ! intent(in) - , rocp & ! intent(in) - , p00 & ! intent(in) - , p00i & ! intent(in) - , tsupercool & ! intent(in) - , cicevlme & ! intent(in) - , cliqvlme & ! intent(in) + use rconstants , only : wdns & ! intent(in) , t00 & ! intent(in) , t3ple & ! intent(in) , day_sec ! ! intent(in) @@ -45,6 +39,9 @@ subroutine soil_moisture_init(n1,n2,n3,mzg,npat,ifm,can_theta,can_prss,glat,glon , slmstr & ! intent(in) , slz ! ! intent(in) use grid_dims , only : str_len ! ! intent(in) + use therm_lib , only : cmtl2uext & ! function + , press2exner & ! function + , extheta2temp ! ! function implicit none !----- Arguments. ----------------------------------------------------------------------! integer , intent(in) :: n1 @@ -62,31 +59,74 @@ subroutine soil_moisture_init(n1,n2,n3,mzg,npat,ifm,can_theta,can_prss,glat,glon real , dimension( n2,n3,npat), intent(inout) :: psibar_10d real , dimension( n2,n3,npat), intent(in) :: leaf_class !----- Local variables. ----------------------------------------------------------------! - character (len=str_len) :: usdata, usmodel + character (len=str_len) :: usdata + character (len=str_len) :: usmodel character (len=20) :: pref - character (len=2) :: cidate,cimon + character (len=2) :: cidate + character (len=2) :: cimon character (len=1) :: cgrid character (len=4) :: ciyear character (len=4) :: cihourmin - integer :: i,j,k,ipat,nveg,nsoil - integer :: qi1,qi2,qj1,qj2,ncount - integer :: ii,jj,jc,ic,i1,j1,i2,j2,kk - integer :: ipref,ipref_start + integer :: i + integer :: j + integer :: k + integer :: ipat + integer :: nveg + integer :: nsoil + integer :: qi1 + integer :: qi2 + integer :: qj1 + integer :: qj2 + integer :: ncount + integer :: ii + integer :: jj + integer :: jc + integer :: ic + integer :: i1 + integer :: j1 + integer :: i2 + integer :: j2 + integer :: kk + integer :: ipref + integer :: ipref_start integer :: icihourmin integer :: n4us - integer :: nlat, nlon - integer :: int_dif_time,da - integer :: idate2,imonth2,iyear2,hourmin - logical :: there,theref,sair,general + integer :: nlat + integer :: nlon + integer :: int_dif_time + integer :: da + integer :: idate2 + integer :: imonth2 + integer :: iyear2 + integer :: hourmin + logical :: there + logical :: theref + logical :: sair + logical :: general real(kind=8) :: dif_time - real, dimension( :) , allocatable :: slz_us,usdum + real, dimension( :) , allocatable :: slz_us + real, dimension( :) , allocatable :: usdum real, dimension(:,:,:) , allocatable :: api_us - real, dimension( :,:) , allocatable :: prlat,prlon - real :: can_temp,soil_temp,soil_fliq - real :: latni,latnf,lonni,lonnf - real :: ilatn,ilonn,ilats,ilons - real :: latn,lonn,lats,lons - real :: dlatr,dlonr + real, dimension( :,:) , allocatable :: prlat + real, dimension( :,:) , allocatable :: prlon + real :: can_exner + real :: can_temp + real :: soil_temp + real :: soil_fliq + real :: latni + real :: latnf + real :: lonni + real :: lonnf + real :: ilatn + real :: ilonn + real :: ilats + real :: ilons + real :: latn + real :: lonn + real :: lats + real :: lons + real :: dlatr + real :: dlonr real :: slmrel real :: swat_new real :: available_water @@ -104,11 +144,12 @@ subroutine soil_moisture_init(n1,n2,n3,mzg,npat,ifm,can_theta,can_prss,glat,glon imonth2 = imontha idate2 = idatea - !----- Determining which kind of soil moisture we are using. ---------------------------! + !----- Determine which kind of soil moisture we are using. -----------------------------! ipref_start = index(usdata_in,'/',back=.true.) + 1 + !---------------------------------------------------------------------------------------! - !----- Defining the layer thickness based on the dataset. ------------------------------! + !----- Define the layer thickness based on the dataset. --------------------------------! ipref = len_trim(usdata_in) pref = usdata_in(ipref_start:ipref) @@ -126,9 +167,10 @@ subroutine soil_moisture_init(n1,n2,n3,mzg,npat,ifm,can_theta,can_prss,glat,glon allocate(slz_us(n4us)) slz_us = (/ -2.4, -0.4, -0.1, 0. /) end select + !---------------------------------------------------------------------------------------! - !----- Making the input/output file name. ----------------------------------------------! + !----- Make the input/output file name. ------------------------------------------------! if ((runtype(1:7) == 'history') .and. & ((soil_moist == 'h') .or. (soil_moist == 'h') .or. & (soil_moist == 'a') .or. (soil_moist == 'a')) ) then @@ -139,16 +181,24 @@ subroutine soil_moisture_init(n1,n2,n3,mzg,npat,ifm,can_theta,can_prss,glat,glon else int_dif_time = 0 end if + !---------------------------------------------------------------------------------------! - !----- Check whether it should look for files up to 5 days older than the initial date. ! + + !---------------------------------------------------------------------------------------! + ! Check whether to look for files up to 5 days older than the initial date or not. ! + !---------------------------------------------------------------------------------------! if ((soil_moist_fail == 'l')) then da = 5 else da = 1 end if + !---------------------------------------------------------------------------------------! sair = .false. + !---------------------------------------------------------------------------------------! + ! Look for the files. ! + !---------------------------------------------------------------------------------------! filefinder: do i=1,da write(cidate,fmt='(i2.2)') idate2 @@ -156,7 +206,7 @@ subroutine soil_moisture_init(n1,n2,n3,mzg,npat,ifm,can_theta,can_prss,glat,glon write(ciyear,fmt='(i4.4)') iyear2 write(cgrid ,fmt='(i1)' ) ifm - !----- Finding the hour of simulation. ----------------------------------------------! + !----- Find- the hour of this simulation. -------------------------------------------! if ((itimea >= 0000).and.(itimea < 1200)) then hourmin = 0000 if(pref == 'GL_SM.GPCP.' .or. pref == 'GL_SM.GPNR.') hourmin = 00 @@ -207,7 +257,13 @@ subroutine soil_moisture_init(n1,n2,n3,mzg,npat,ifm,can_theta,can_prss,glat,glon if (sair) exit filefinder call alt_dia(idatea, imontha, iyeara,(int_dif_time-i),idate2, imonth2, iyear2) end do filefinder + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! Check whether the soil moisture file exists. ! + !---------------------------------------------------------------------------------------! inquire (file=trim(usmodel),exist=there) size_usmodel = filesize4(trim(usmodel)) @@ -225,6 +281,7 @@ subroutine soil_moisture_init(n1,n2,n3,mzg,npat,ifm,can_theta,can_prss,glat,glon else write(unit=*,fmt='(a)') ' Failed initialising heterogeneous soil moisture...' write(unit=*,fmt='(a)') ' Going for a homogeneous initial state.' + deallocate(slz_us) return end if end if @@ -240,24 +297,36 @@ subroutine soil_moisture_init(n1,n2,n3,mzg,npat,ifm,can_theta,can_prss,glat,glon hoiloop: do i = 1,n2 nveg = nint(leaf_class(i,j,ipat)) - !----- Finding canopy temperature for this patch. --------------------------! - can_temp = can_theta(i,j,ipat) * (p00i * can_prss(i,j,ipat)) ** rocp + !----- Find canopy temperature for this patch. -----------------------------! + can_exner = press2exner (can_prss(i,j,ipat)) + can_temp = extheta2temp(can_exner,can_theta(i,j,ipat)) available_water = 0.0 hokloop: do k = 1,mzg nsoil = nint(soil_text(k,i,j,ipat)) + !----- Initialise homogeneous soil moisture and temperature. ------------! soil_water(k,i,j,ipat) = soil_idx2water(slmstr(k),nsoil) soil_temp = can_temp + stgoff(k) - if (soil_temp >= t3ple) then - soil_energy(k,i,j,ipat) = slcpd(nsoil) * soil_temp & - + soil_water(k,i,j,ipat) * cliqvlme & - * (soil_temp-tsupercool) + !------------------------------------------------------------------------! + + + !----- Make liquid fraction consistent with temperature. ----------------! + if (soil_temp == t3ple) then + soil_fliq = 0.5 + elseif (soil_temp > t3ple) then soil_fliq = 1.0 else - soil_energy(k,i,j,ipat) = soil_temp * ( slcpd(nsoil) & - + soil_water(k,i,j,ipat)*cicevlme) soil_fliq = 0.0 end if + !------------------------------------------------------------------------! + + + !----- Internal energy. -------------------------------------------------! + soil_energy(k,i,j,ipat) = cmtl2uext( slcpd(nsoil) & + , soil_water(k,i,j,ipat) * wdns & + , soil_temp , soil_fliq ) + !------------------------------------------------------------------------! + !------ Integrate the relative potential. -------------------------------! if (k >= kroot(nveg) .and. nsoil /= 13) then @@ -279,8 +348,11 @@ subroutine soil_moisture_init(n1,n2,n3,mzg,npat,ifm,can_theta,can_prss,glat,glon !---------------------------------------------------------------------------! end do hoiloop + !------------------------------------------------------------------------------! end do hojloop + !---------------------------------------------------------------------------------! end do hoploop + !------------------------------------------------------------------------------------! write(unit=*,fmt='(a)') '|------------------------------------------------|' @@ -288,7 +360,7 @@ subroutine soil_moisture_init(n1,n2,n3,mzg,npat,ifm,can_theta,can_prss,glat,glon write(unit=*,fmt='(a)') '| points within the input domain |' write(unit=*,fmt='(a)') '|------------------------------------------------|' - !----- Defining the domain boundaries. ----------------------------------------------! + !----- Define the domain boundaries. ---------------==-------------------------------! inquire (file=TRIM(usdata_in)//'_ENT', exist=general) if (general) then open (unit=93,file=TRIM(usdata_in)//'_ENT',status='old') @@ -352,10 +424,12 @@ subroutine soil_moisture_init(n1,n2,n3,mzg,npat,ifm,can_theta,can_prss,glat,glon end select end if - allocate(prlat(nlon,nlat),prlon(nlon,nlat)) + allocate(prlat(nlon,nlat)) + allocate(prlon(nlon,nlat)) call api_prlatlon(nlon,nlat,prlat,prlon,ilatn,ilonn,latni,lonni) - allocate(api_us(nlon,nlat,n4us),usdum(n4us)) + allocate(api_us(nlon,nlat,n4us)) + allocate(usdum (n4us)) write(unit=*,fmt='(a)') '------------------------------------------------' @@ -523,38 +597,54 @@ subroutine soil_moisture_init(n1,n2,n3,mzg,npat,ifm,can_theta,can_prss,glat,glon nveg = nint(leaf_class(i,j,ipat)) !----- Find the canopy temperature for this patch. ----------------------------! - can_temp = can_theta(i,j,ipat) * (p00i * can_prss(i,j,ipat)) ** rocp + can_exner = press2exner (can_prss(i,j,ipat)) + can_temp = extheta2temp(can_exner,can_theta(i,j,ipat)) available_water = 0.0 hekloop: do k = 1,mzg nsoil = nint(soil_text(k,i,j,ipat)) - !----- Make sure that the soil moisture is bounded... ----------------------! - soil_water(k,i,j,npat) = max(soilcp(nsoil) & + + !---------------------------------------------------------------------------! + ! Initialise homogeneous soil moisture and temperature. Make sure ! + ! that moisture is bounded. ! + !---------------------------------------------------------------------------! + soil_water(k,i,j,ipat) = max(soilcp(nsoil) & ,min(soil_water(k,i,j,ipat), slmsts(nsoil))) - soil_temp = can_temp + stgoff(k) + soil_temp = can_temp + stgoff(k) + !---------------------------------------------------------------------------! - if (soil_temp >= t3ple) then - soil_energy(k,i,j,ipat) = slcpd(nsoil) * soil_temp & - + soil_water(k,i,j,ipat) * cliqvlme & - * (soil_temp-tsupercool) + + !----- Make liquid fraction consistent with temperature. -------------------! + if (soil_temp == t3ple) then + soil_fliq = 0.5 + elseif (soil_temp > t3ple) then soil_fliq = 1.0 else - soil_energy(k,i,j,ipat) = soil_temp * ( slcpd(nsoil) & - + soil_water(k,i,j,ipat) * cicevlme) soil_fliq = 0.0 end if + !---------------------------------------------------------------------------! + + + !----- Internal energy. ----------------------------------------------------! + soil_energy(k,i,j,ipat) = cmtl2uext( slcpd(nsoil) & + , soil_water(k,i,j,ipat) * wdns & + , soil_temp , soil_fliq ) + !---------------------------------------------------------------------------! !------ Integrate the relative potential. ----------------------------------! if (k >= kroot(nveg) .and. nsoil /= 13) then psi_layer = slpots(nsoil) & - / (soil_water(k,i,j,ipat) / slmsts(nsoil)) ** slbs(nsoil) + / (soil_water(k,i,j,ipat) / slmsts(nsoil)) & + ** slbs(nsoil) available_water = available_water & - + max(0., (psi_layer - psiwp(nsoil)) & + + max(0., (psi_layer - psiwp(nsoil)) & / (psild(nsoil) - psiwp(nsoil)) ) & * soil_fliq * (slz(k+1)-slz(k)) end if !---------------------------------------------------------------------------! end do hekloop + !------------------------------------------------------------------------------! + !----- Normalise the available water. -----------------------------------------! available_water = available_water / abs(slz(kroot(nveg))) @@ -564,6 +654,10 @@ subroutine soil_moisture_init(n1,n2,n3,mzg,npat,ifm,can_theta,can_prss,glat,glon end do hejloop end do heploop + !----- Free memory. --------------------------------------------------------------------! + deallocate(slz_us) + !---------------------------------------------------------------------------------------! + return end subroutine soil_moisture_init !==========================================================================================! diff --git a/BRAMS/src/surface/leaf3.f90 b/BRAMS/src/surface/leaf3.f90 index a4e1add43..c8b23943b 100644 --- a/BRAMS/src/surface/leaf3.f90 +++ b/BRAMS/src/surface/leaf3.f90 @@ -62,10 +62,11 @@ subroutine leaf3_timestep() , dtll_factor & ! intent(in) , dtll & ! intent(in) , atm_theta & ! intent(out) - , atm_theiv & ! intent(out) + , atm_enthalpy & ! intent(out) , atm_shv & ! intent(out) , atm_rvap & ! intent(out) , atm_co2 & ! intent(out) + , can_enthalpy & ! intent(out) , can_shv & ! intent(out) , can_rhos & ! intent(out) , geoht & ! intent(out) @@ -86,20 +87,14 @@ subroutine leaf3_timestep() , co2_on & ! intent(in) , co2con ! ! intent(in) use mem_turb , only : turb_g ! ! intent(inout) - use mem_cuparm , only : cuparm_g & ! intent(in) - , nnqparm & ! intent(in) - , nclouds ! ! intent(in) - use mem_micro , only : micro_g ! ! intent(in) use mem_radiate , only : radiate_g & ! intent(inout) , iswrtyp & ! intent(in) , ilwrtyp ! ! intent(in) - use therm_lib , only : bulk_on ! ! intent(in) - use rconstants , only : p00 & ! intent(in) - , cpi & ! intent(in) - , cpor & ! intent(in) - , rocp & ! intent(in) - , cp & ! intent(in) - , alvl ! ! intent(in) + use therm_lib , only : press2exner & ! function + , exner2press & ! function + , extheta2temp ! ! function + use rconstants , only : alvl3 & ! intent(in) + , cpdry ! ! intent(in) implicit none !----- Local variables. ----------------------------------------------------------------! integer :: i @@ -142,121 +137,10 @@ subroutine leaf3_timestep() !---------------------------------------------------------------------------------------! - !---------------------------------------------------------------------------------------! - ! Here we copy a few variables to scratch arrays, as they may not be always exist. ! - ! In case they don't, we fill the scratch arrays with the default values. The follow- ! - ! ing scratch arrays will contain the following fields. ! - ! ! - ! vt3do => CO2 mixing ratio ! - ! vt3dp => precipitation rate from cumulus parametrisation. ! - ! vt2dq => precipitation rate from bulk microphysics ! - ! vt2dr => internal energy associated with precipitation rate from bulk microphysics ! - ! vt2ds => depth associated with precipitation rate from bulk microphysics ! + ! Call several initialisation sub-routines. ! !---------------------------------------------------------------------------------------! - !----- Check whether we have CO2, and copy to an scratch array. ------------------------! - if (co2_on) then - call atob(mzp*mxp*myp,basic_g(ngrid)%co2p,scratch%vt3do) - else - call ae0(mzp*mxp*myp,scratch%vt3do,co2con(1)) - end if - !----- Check whether cumulus parametrisation was used, and copy to scratch array. ------! - if (nnqparm(ngrid) /= 0) then - call atob(mxp*myp*nclouds,cuparm_g(ngrid)%conprr,scratch%vt3dp) - else - call azero(mxp*myp*nclouds,scratch%vt3dp) - end if - !----- Check whether bulk microphysics was used, and copy values to scratch array. -----! - if (bulk_on) then - call atob(mxp*myp,micro_g(ngrid)%pcpg ,scratch%vt2dq) - call atob(mxp*myp,micro_g(ngrid)%qpcpg,scratch%vt2dr) - call atob(mxp*myp,micro_g(ngrid)%dpcpg,scratch%vt2ds) - else - call azero(mxp*myp,scratch%vt2dq) - call azero(mxp*myp,scratch%vt2dr) - call azero(mxp*myp,scratch%vt2ds) - end if - !---------------------------------------------------------------------------------------! - - - - - !---------------------------------------------------------------------------------------! - ! Copy surface atmospheric variables into 2-D arrays for input to LEAF. The 2-D ! - ! arrays are save as the following: !! - ! ! - ! vt2da => ice-liquid potential temperature ! - ! vt2db => potential temperature ! - ! vt2dc => water vapour mixing ratio ! - ! vt2dd => total water mixing ratio (ice + liquid + vapour) ! - ! vt2de => CO2 mixing ratio ! - ! vt2df => zonal wind speed ! - ! vt2dg => meridional wind speed ! - ! vt2dh => Exner function ! - ! vt2di => Air density ! - ! vt2dj => Reference height ! - ! vt2dk => Precipitation rate ! - ! vt2dl => Internal energy of precipitation rate ! - ! vt2dm => Depth associated with the precipitation rate ! - !---------------------------------------------------------------------------------------! - select case (if_adap) - case (0) - call sfc_fields( mzp,mxp,myp,ia,iz,ja,jz,jdim & - , basic_g(ngrid)%thp , basic_g(ngrid)%theta , basic_g(ngrid)%rv & - , basic_g(ngrid)%rtp , scratch%vt3do , basic_g(ngrid)%up & - , basic_g(ngrid)%vp , basic_g(ngrid)%dn0 , basic_g(ngrid)%pp & - , basic_g(ngrid)%pi0 , grid_g(ngrid)%rtgt , zt & - , zm , scratch%vt2da , scratch%vt2db & - , scratch%vt2dc , scratch%vt2dd , scratch%vt2de & - , scratch%vt2df , scratch%vt2dg , scratch%vt2dh & - , scratch%vt2di , scratch%vt2dj ) - case (1) - call sfc_fields_adap(mzp,mxp,myp,ia,iz,ja,jz,jdim & - , grid_g(ngrid)%flpu , grid_g(ngrid)%flpv , grid_g(ngrid)%flpw & - , grid_g(ngrid)%topma , grid_g(ngrid)%aru , grid_g(ngrid)%arv & - , basic_g(ngrid)%thp , basic_g(ngrid)%theta , basic_g(ngrid)%rv & - , basic_g(ngrid)%rtp , scratch%vt3do , basic_g(ngrid)%up & - , basic_g(ngrid)%vp , basic_g(ngrid)%dn0 , basic_g(ngrid)%pp & - , basic_g(ngrid)%pi0 , zt , zm & - , dzt , scratch%vt2da , scratch%vt2db & - , scratch%vt2dc , scratch%vt2dd , scratch%vt2de & - , scratch%vt2df , scratch%vt2dg , scratch%vt2dh & - , scratch%vt2di , scratch%vt2dj ) - end select - !---------------------------------------------------------------------------------------! - - - - !----- Fill surface precipitation arrays for input to LEAF-3 ---------------------------! - call sfc_pcp(mxp,myp,nclouds,ia,iz,ja,jz,dtll,dtll_factor,scratch%vt2db,scratch%vt2dh & - ,scratch%vt3dp,scratch%vt2dq,scratch%vt2dr,scratch%vt2ds,scratch%vt2dk & - ,scratch%vt2dl,scratch%vt2dm) - !---------------------------------------------------------------------------------------! - - - !---------------------------------------------------------------------------------------! - ! Reset fluxes, albedo, and upwelling long-wave radiation. ! - !---------------------------------------------------------------------------------------! - call azero(mxp*myp ,turb_g(ngrid)%sflux_u ) - call azero(mxp*myp ,turb_g(ngrid)%sflux_v ) - call azero(mxp*myp ,turb_g(ngrid)%sflux_w ) - call azero(mxp*myp ,turb_g(ngrid)%sflux_t ) - call azero(mxp*myp ,turb_g(ngrid)%sflux_r ) - call azero(mxp*myp ,turb_g(ngrid)%sflux_c ) - call azero(mxp*myp*npatch,leaf_g(ngrid)%sensible_gc) - call azero(mxp*myp*npatch,leaf_g(ngrid)%sensible_vc) - call azero(mxp*myp*npatch,leaf_g(ngrid)%evap_gc ) - call azero(mxp*myp*npatch,leaf_g(ngrid)%evap_vc ) - call azero(mxp*myp*npatch,leaf_g(ngrid)%transp ) - call azero(mxp*myp*npatch,leaf_g(ngrid)%gpp ) - call azero(mxp*myp*npatch,leaf_g(ngrid)%plresp ) - call azero(mxp*myp*npatch,leaf_g(ngrid)%resphet ) - call azero(mxp*myp*npatch,leaf_g(ngrid)%rshort_gnd ) - call azero(mxp*myp*npatch,leaf_g(ngrid)%rlong_gnd ) - if (iswrtyp > 0 .or. ilwrtyp > 0) then - call azero(mxp*myp,radiate_g(ngrid)%albedt) - call azero(mxp*myp,radiate_g(ngrid)%rlongup) - end if + call leaf3_step_startup() !---------------------------------------------------------------------------------------! @@ -452,12 +336,12 @@ subroutine leaf3_timestep() !----- Compute the characteristic scales. ----------------------------------! call leaf3_stars(atm_theta & - ,atm_theiv & + ,atm_enthalpy & ,atm_shv & ,atm_rvap & ,atm_co2 & ,leaf_g(ngrid)%can_theta (i,j,ip) & - ,leaf_g(ngrid)%can_theiv (i,j,ip) & + ,can_enthalpy & ,can_shv & ,leaf_g(ngrid)%can_rvap (i,j,ip) & ,leaf_g(ngrid)%can_co2 (i,j,ip) & @@ -532,7 +416,7 @@ subroutine leaf3_timestep() ,leaf_g(ngrid)%leaf_class (i,j,ip) & ,leaf_g(ngrid)%can_prss (i,j,ip) & ,.false. ) - call leaf3_veg_diag(leaf_g(ngrid)%veg_energy (i,j,ip) & + call leaf3_veg_diag(leaf_g(ngrid)%veg_energy (i,j,ip) & ,leaf_g(ngrid)%veg_water (i,j,ip) & ,leaf_g(ngrid)%veg_hcap (i,j,ip) ) case default @@ -543,17 +427,17 @@ subroutine leaf3_timestep() if (nint(leaf_g(ngrid)%g_urban(i,j,ip)) /= 0.) then !---- Initialise a few variables. ---------------------------------! - psup1 = p00 * (cpi * ( basic_g(ngrid)%pi0(1,i,j) & - + basic_g(ngrid)%pp (1,i,j)))**cpor - psup2 = p00 * (cpi * ( basic_g(ngrid)%pi0(2,i,j) & - + basic_g(ngrid)%pp (2,i,j)))**cpor + psup1 = exner2press( basic_g(ngrid)%pi0(1,i,j) & + + basic_g(ngrid)%pp (1,i,j)) + psup2 = exner2press( basic_g(ngrid)%pi0(2,i,j) & + + basic_g(ngrid)%pp (2,i,j)) depe = psup2-psup1 alt2 = zt(1)*grid_g(ngrid)%rtgt(i,j) deze = geoht-alt2 dpdz = depe/deze - exn1st = (psup2/p00)**rocp + exn1st = press2exner(psup2) - airt= basic_g(ngrid)%theta(2,i,j)*exn1st + airt= extheta2temp(exn1st,basic_g(ngrid)%theta(2,i,j)) g_urban = leaf_g(ngrid)%g_urban(i,j,ip) @@ -606,10 +490,10 @@ subroutine leaf3_timestep() + leaf_g(ngrid)%patch_area(i,j,ip) * zsfv_town turb_g(ngrid)%sflux_t(i,j) = turb_g(ngrid)%sflux_t(i,j) & + leaf_g(ngrid)%patch_area(i,j,ip) * zh_town & - / (cp * can_rhos) + / (cpdry * can_rhos) turb_g(ngrid)%sflux_r(i,j) = turb_g(ngrid)%sflux_r(i,j) & + leaf_g(ngrid)%patch_area(i,j,ip) * zle_town & - / (alvl * can_rhos) + / (alvl3 * can_rhos) end if end if @@ -758,3 +642,176 @@ subroutine leaf3_timestep() end subroutine leaf3_timestep !==========================================================================================! !==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +subroutine leaf3_step_startup() + use mem_basic , only : basic_g & ! intent(in) + , co2_on & ! intent(in) + , co2con ! ! intent(in) + use node_mod , only : mzp & ! intent(in) + , mxp & ! intent(in) + , myp & ! intent(in) + , ia & ! intent(in) + , iz & ! intent(in) + , ja & ! intent(in) + , jz & ! intent(in) + , ibcon & ! intent(in) + , mynum ! ! intent(in) + use mem_scratch , only : scratch ! ! intent(inout) + use mem_grid , only : nstbot & ! intent(in) + , ngrid & ! intent(in) + , grid_g & ! intent(in) + , time & ! intent(in) + , dtlt & ! intent(in) + , dzt & ! intent(in) + , zt & ! intent(in) + , zm & ! intent(in) + , nzg & ! intent(in) + , nzs & ! intent(in) + , istp & ! intent(in) + , npatch & ! intent(in) + , jdim & ! intent(in) + , itimea & ! intent(in) + , if_adap ! ! intent(in) + use mem_cuparm , only : cuparm_g & ! intent(in) + , nnqparm & ! intent(in) + , nclouds ! ! intent(in) + use mem_micro , only : micro_g ! ! intent(in) + use leaf_coms , only : dtll & ! intent(in) + , dtll_factor ! ! intent(in) + use mem_turb , only : turb_g ! ! intent(in) + use mem_leaf , only : leaf_g ! ! intent(in) + use mem_radiate , only : radiate_g & ! intent(inout) + , iswrtyp & ! intent(in) + , ilwrtyp ! ! intent(in) + use therm_lib , only : bulk_on ! ! intent(in) + implicit none + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! Here we copy a few variables to scratch arrays, as they may not be always exist. ! + ! In case they don't, we fill the scratch arrays with the default values. The follow- ! + ! ing scratch arrays will contain the following fields. ! + ! ! + ! vt3do => CO2 mixing ratio ! + ! vt3dp => precipitation rate from cumulus parametrisation. ! + ! vt2dq => precipitation rate from bulk microphysics ! + ! vt2dr => internal energy associated with precipitation rate from bulk microphysics ! + ! vt2ds => depth associated with precipitation rate from bulk microphysics ! + !---------------------------------------------------------------------------------------! + !----- Check whether we have CO2, and copy to an scratch array. ------------------------! + if (co2_on) then + call atob(mzp*mxp*myp,basic_g(ngrid)%co2p,scratch%vt3do) + else + call ae0(mzp*mxp*myp,scratch%vt3do,co2con(1)) + end if + !----- Check whether cumulus parametrisation was used, and copy to scratch array. ------! + if (nnqparm(ngrid) /= 0) then + call atob(mxp*myp*nclouds,cuparm_g(ngrid)%conprr,scratch%vt3dp) + else + call azero(mxp*myp*nclouds,scratch%vt3dp) + end if + !----- Check whether bulk microphysics was used, and copy values to scratch array. -----! + if (bulk_on) then + call atob(mxp*myp,micro_g(ngrid)%pcpg ,scratch%vt2dq) + call atob(mxp*myp,micro_g(ngrid)%qpcpg,scratch%vt2dr) + call atob(mxp*myp,micro_g(ngrid)%dpcpg,scratch%vt2ds) + else + call azero(mxp*myp,scratch%vt2dq) + call azero(mxp*myp,scratch%vt2dr) + call azero(mxp*myp,scratch%vt2ds) + end if + !---------------------------------------------------------------------------------------! + + + + + !---------------------------------------------------------------------------------------! + ! Copy surface atmospheric variables into 2-D arrays for input to LEAF. The 2-D ! + ! arrays are save as the following: !! + ! ! + ! vt2da => ice-liquid potential temperature ! + ! vt2db => potential temperature ! + ! vt2dc => water vapour mixing ratio ! + ! vt2dd => total water mixing ratio (ice + liquid + vapour) ! + ! vt2de => CO2 mixing ratio ! + ! vt2df => zonal wind speed ! + ! vt2dg => meridional wind speed ! + ! vt2dh => Exner function ! + ! vt2di => Air density ! + ! vt2dj => Reference height ! + ! vt2dk => Precipitation rate ! + ! vt2dl => Internal energy of precipitation rate ! + ! vt2dm => Depth associated with the precipitation rate ! + !---------------------------------------------------------------------------------------! + select case (if_adap) + case (0) + call sfc_fields( mzp,mxp,myp,ia,iz,ja,jz,jdim & + , basic_g(ngrid)%thp , basic_g(ngrid)%theta , basic_g(ngrid)%rv & + , basic_g(ngrid)%rtp , scratch%vt3do , basic_g(ngrid)%up & + , basic_g(ngrid)%vp , basic_g(ngrid)%dn0 , basic_g(ngrid)%pp & + , basic_g(ngrid)%pi0 , grid_g(ngrid)%rtgt , zt & + , zm , scratch%vt2da , scratch%vt2db & + , scratch%vt2dc , scratch%vt2dd , scratch%vt2de & + , scratch%vt2df , scratch%vt2dg , scratch%vt2dh & + , scratch%vt2di , scratch%vt2dj ) + case (1) + call sfc_fields_adap(mzp,mxp,myp,ia,iz,ja,jz,jdim & + , grid_g(ngrid)%flpu , grid_g(ngrid)%flpv , grid_g(ngrid)%flpw & + , grid_g(ngrid)%topma , grid_g(ngrid)%aru , grid_g(ngrid)%arv & + , basic_g(ngrid)%thp , basic_g(ngrid)%theta , basic_g(ngrid)%rv & + , basic_g(ngrid)%rtp , scratch%vt3do , basic_g(ngrid)%up & + , basic_g(ngrid)%vp , basic_g(ngrid)%dn0 , basic_g(ngrid)%pp & + , basic_g(ngrid)%pi0 , zt , zm & + , dzt , scratch%vt2da , scratch%vt2db & + , scratch%vt2dc , scratch%vt2dd , scratch%vt2de & + , scratch%vt2df , scratch%vt2dg , scratch%vt2dh & + , scratch%vt2di , scratch%vt2dj ) + end select + !---------------------------------------------------------------------------------------! + + + + !----- Fill surface precipitation arrays for input to LEAF-3 ---------------------------! + call sfc_pcp(mxp,myp,nclouds,ia,iz,ja,jz,dtll,dtll_factor,scratch%vt2db,scratch%vt2dh & + ,scratch%vt3dp,scratch%vt2dq,scratch%vt2dr,scratch%vt2ds,scratch%vt2dk & + ,scratch%vt2dl,scratch%vt2dm) + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! Reset fluxes, albedo, and upwelling long-wave radiation. ! + !---------------------------------------------------------------------------------------! + call azero(mxp*myp ,turb_g(ngrid)%sflux_u ) + call azero(mxp*myp ,turb_g(ngrid)%sflux_v ) + call azero(mxp*myp ,turb_g(ngrid)%sflux_w ) + call azero(mxp*myp ,turb_g(ngrid)%sflux_t ) + call azero(mxp*myp ,turb_g(ngrid)%sflux_r ) + call azero(mxp*myp ,turb_g(ngrid)%sflux_c ) + call azero(mxp*myp*npatch,leaf_g(ngrid)%sensible_gc) + call azero(mxp*myp*npatch,leaf_g(ngrid)%sensible_vc) + call azero(mxp*myp*npatch,leaf_g(ngrid)%evap_gc ) + call azero(mxp*myp*npatch,leaf_g(ngrid)%evap_vc ) + call azero(mxp*myp*npatch,leaf_g(ngrid)%transp ) + call azero(mxp*myp*npatch,leaf_g(ngrid)%gpp ) + call azero(mxp*myp*npatch,leaf_g(ngrid)%plresp ) + call azero(mxp*myp*npatch,leaf_g(ngrid)%resphet ) + call azero(mxp*myp*npatch,leaf_g(ngrid)%rshort_gnd ) + call azero(mxp*myp*npatch,leaf_g(ngrid)%rlong_gnd ) + if (iswrtyp > 0 .or. ilwrtyp > 0) then + call azero(mxp*myp,radiate_g(ngrid)%albedt) + call azero(mxp*myp,radiate_g(ngrid)%rlongup) + end if + !---------------------------------------------------------------------------------------! + + return +end subroutine leaf3_step_startup +!==========================================================================================! +!==========================================================================================! diff --git a/BRAMS/src/surface/leaf3_can.f90 b/BRAMS/src/surface/leaf3_can.f90 index bac7bba70..3b20e1fe6 100644 --- a/BRAMS/src/surface/leaf3_can.f90 +++ b/BRAMS/src/surface/leaf3_can.f90 @@ -16,9 +16,10 @@ subroutine leaf3_canopy(mzg,mzs,ksn,soil_energy,soil_water,soil_text,sfcwater_ma use therm_lib , only : eslif & ! function , rslif & ! function , thetaeiv & ! function - , thrhsh2temp & ! function , tslif & ! function - , qwtk ! ! subroutine + , uextcm2tl & ! subroutine + , tl2uint & ! function + , tq2enthalpy ! ! function use catt_start, only : CATT implicit none !----- Arguments. ----------------------------------------------------------------------! @@ -123,7 +124,7 @@ subroutine leaf3_canopy(mzg,mzs,ksn,soil_energy,soil_water,soil_text,sfcwater_ma !----- Find the time step auxiliary variables. -----------------------------------------! dtllowcc = dtll / (can_depth * can_rhos) - dtllohcc = dtll / (can_depth * can_rhos * cp * can_temp) + dtllohcc = dtll / (can_depth * can_rhos) dtlloccc = dtllowcc * mmdry !---------------------------------------------------------------------------------------! @@ -133,7 +134,7 @@ subroutine leaf3_canopy(mzg,mzs,ksn,soil_energy,soil_water,soil_text,sfcwater_ma ! Find the atmosphere -> canopy fluxes. ! !---------------------------------------------------------------------------------------! rho_ustar = can_rhos * ustar - eflxac = rho_ustar * estar * cp * can_temp ! Enthalpy exchange + eflxac = rho_ustar * estar ! Enthalpy exchange hflxac = rho_ustar * tstar * can_exner ! Sensible heat exchange wflxac = rho_ustar * rstar ! Water vapour exchange cflxac = rho_ustar * cstar * mmdryi ! CO2 exchange @@ -213,8 +214,8 @@ subroutine leaf3_canopy(mzg,mzs,ksn,soil_energy,soil_water,soil_text,sfcwater_ma ! Both are defined as positive quantities. Sensible heat is defined by only one ! ! variable, hflxgc [J/m2/s], which can be either positive or negative. ! !---------------------------------------------------------------------------------------! - hflxgc = ggnet * can_rhos * cp * (ground_temp - can_temp) - wflx = ggnet * can_rhos * (ground_rsat - can_rvap) + hflxgc = ggnet * can_rhos * can_cp * (ground_temp - can_temp) + wflx = ggnet * can_rhos * (ground_rsat - can_rvap) !---------------------------------------------------------------------------------------! @@ -234,7 +235,7 @@ subroutine leaf3_canopy(mzg,mzs,ksn,soil_energy,soil_water,soil_text,sfcwater_ma ! density based on MCD suggestion on 11/16/2009. ! !------------------------------------------------------------------------------------! dewgndflx = min(-wflx,(can_rvap - toodry) / dtllowcc) - qdewgndflx = dewgndflx * (alvi - ground_fliq * alli) + qdewgndflx = dewgndflx * tq2enthalpy(ground_temp,1.0,.true.) ddewgndflx = dewgndflx * (ground_fliq * wdnsi + (1.0-ground_fliq) * fdnsi) !----- Set evaporation fluxes to zero. ----------------------------------------------! wflxgc = 0.0 @@ -262,7 +263,7 @@ subroutine leaf3_canopy(mzg,mzs,ksn,soil_energy,soil_water,soil_text,sfcwater_ma qdewgndflx = 0.0 ddewgndflx = 0.0 wflxgc = max(0.,min(wflx,sfcwater_mass(ksn)/dtll)) - qwflxgc = wflx * (alvi - ground_fliq * alli) + qwflxgc = wflx * tq2enthalpy(ground_temp,1.0,.true.) else !------------------------------------------------------------------------------------! @@ -274,7 +275,7 @@ subroutine leaf3_canopy(mzg,mzs,ksn,soil_energy,soil_water,soil_text,sfcwater_ma !------------------------------------------------------------------------------------! wflxgc = can_rhos * ggnet * ggsoil * (ground_rvap - can_rvap) / (ggnet + ggsoil) !----- Adjust the flux according to the surface fraction (no phase bias). -----------! - qwflxgc = wflxgc * ( alvi - ground_fliq * alli) + qwflxgc = wflxgc * tq2enthalpy(ground_temp,1.0,.true.) !----- Set condensation fluxes to zero. ---------------------------------------------! dewgndflx = 0.0 qdewgndflx = 0.0 @@ -312,7 +313,8 @@ subroutine leaf3_canopy(mzg,mzs,ksn,soil_energy,soil_water,soil_text,sfcwater_ma ! Find the aerodynamic conductances for heat and water at the leaf boundary ! ! layer. ! !------------------------------------------------------------------------------------! - call leaf3_aerodynamic_conductances(nveg,veg_wind,veg_temp,can_temp,can_rvap,can_rhos) + call leaf3_aerodynamic_conductances(nveg,veg_wind,veg_temp,can_temp,can_rvap & + ,can_rhos,can_cp) !------------------------------------------------------------------------------------! @@ -462,8 +464,7 @@ subroutine leaf3_canopy(mzg,mzs,ksn,soil_energy,soil_water,soil_text,sfcwater_ma elseif (wtemp > leaf_maxwhc * stai) then !----- Shed water in excess of the leaf holding water capacity. ------------------! wshed_tot = wtemp - leaf_maxwhc * stai - qwshed_tot = wshed_tot * ( veg_fliq * cliq * (veg_temp - tsupercool) & - + (1.-veg_fliq) * cice * veg_temp ) + qwshed_tot = wshed_tot * tl2uint(veg_temp,veg_fliq) dwshed_tot = wshed_tot * (veg_fliq * wdnsi + (1.0 - veg_fliq) * fdnsi) veg_water = leaf_maxwhc * stai else @@ -477,8 +478,8 @@ subroutine leaf3_canopy(mzg,mzs,ksn,soil_energy,soil_water,soil_text,sfcwater_ma !------ Find the associated latent heat flux from vegetation to canopy. -------------! - qwflxvc = wflxvc * (alvi - alli * veg_fliq) - qtransp_loc = transp_loc * alvl !----- Liquid phase only in transpiration. ---------! + qwflxvc = wflxvc * tq2enthalpy(veg_temp,1.0,.true.) + qtransp_loc = transp_loc * tq2enthalpy(veg_temp,1.0,.true.) !------------------------------------------------------------------------------------! @@ -498,10 +499,12 @@ subroutine leaf3_canopy(mzg,mzs,ksn,soil_energy,soil_water,soil_text,sfcwater_ma !------------------------------------------------------------------------------------! ! Update enthalpy, CO2, and canopy mixing ratio. ! !------------------------------------------------------------------------------------! - can_lntheta = can_lntheta & - + dtllohcc * ( hflxgc + hflxvc + hflxac) - can_rvap = can_rvap & - + dtllowcc * (wflxgc - dewgndflx + wflxvc + transp_loc + wflxac) + can_enthalpy = can_enthalpy & + + dtllohcc * ( hflxgc + qwflxgc - qdewgndflx & + + hflxvc + qwflxvc + qtransp_loc & + + eflxac) + can_rvap = can_rvap & + + dtllowcc * ( wflxgc - dewgndflx + wflxvc + transp_loc + wflxac) !------------------------------------------------------------------------------------! @@ -531,7 +534,7 @@ subroutine leaf3_canopy(mzg,mzs,ksn,soil_energy,soil_water,soil_text,sfcwater_ma !------------------------------------------------------------------------------------! !----- Update the canopy prognostic variables. --------------------------------------! - can_lntheta = can_lntheta + dtllohcc * (hflxgc + qwflxgc + hflxac) + can_enthalpy = can_enthalpy + dtllohcc * (hflxgc + qwflxgc - qdewgndflx + eflxac) can_rvap = can_rvap + dtllowcc * (wflxgc - dewgndflx + wflxac) !------------------------------------------------------------------------------------! @@ -567,6 +570,8 @@ subroutine leaf3_can_diag(ip,can_theta,can_theiv,can_rvap,leaf_class,can_prss,in use leaf_coms , only : atm_prss & ! intent(in) , atm_theta & ! intent(in) , atm_shv & ! intent(in) + , atm_temp_zcan & ! intent(in) + , atm_enthalpy & ! intent(in) , geoht & ! intent(in) , veg_ht & ! intent(in) , can_shv & ! intent(out) @@ -576,17 +581,24 @@ subroutine leaf3_can_diag(ip,can_theta,can_theiv,can_rvap,leaf_class,can_prss,in , can_depth_min & ! intent(in) , can_temp & ! intent(out) , can_exner & ! intent(inout) - , can_lntheta & ! intent(inout) - , can_rhos ! ! intent(inout) - use rconstants, only : cp & ! intent(in) - , cpi & ! intent(in) + , can_enthalpy & ! intent(inout) + , can_rhos & ! intent(inout) + , can_cp ! ! intent(inout) + use rconstants, only : cpdry & ! intent(in) + , cph2o & ! intent(in) , ep & ! intent(in) , p00i & ! intent(in) , rocp ! ! intent(in) use therm_lib , only : reducedpress & ! function , rslif & ! function , idealdenssh & ! function - , thetaeiv ! ! function + , thetaeiv & ! function + , press2exner & ! function + , extheta2temp & ! function + , extemp2theta & ! function + , tq2enthalpy & ! function + , hq2temp ! ! function + implicit none !----- Arguments. ----------------------------------------------------------------------! integer, intent(in) :: ip @@ -622,21 +634,6 @@ subroutine leaf3_can_diag(ip,can_theta,can_theiv,can_rvap,leaf_class,can_prss,in - - !---------------------------------------------------------------------------------------! - ! If this is the initial step, we initialise the canopy air "dry enthropy" (log of ! - ! potential temperature). If not, we update the actual potential temperature from the ! - ! logarithm. ! - !---------------------------------------------------------------------------------------! - if (initial) then - can_lntheta = log(can_theta) - else - can_theta = exp(can_lntheta) - end if - !---------------------------------------------------------------------------------------! - - - !---------------------------------------------------------------------------------------! ! Update canopy air pressure and the Exner function here. Canopy air pressure is ! ! assumed to remain constant during one LEAF full timestep, which means that heat ! @@ -648,7 +645,12 @@ subroutine leaf3_can_diag(ip,can_theta,can_theiv,can_rvap,leaf_class,can_prss,in if (initial) then can_prss = reducedpress(atm_prss,atm_theta,atm_shv,geoht,can_theta,can_shv & ,can_depth) - can_exner = cp * (p00i * can_prss) ** rocp + can_exner = press2exner(can_prss) + + !----- Also, find the specific enthalpy of the air aloft. ---------------------------! + atm_temp_zcan = extheta2temp(can_exner,atm_theta) + atm_enthalpy = tq2enthalpy(atm_temp_zcan,atm_shv,.true.) + !------------------------------------------------------------------------------------! end if !---------------------------------------------------------------------------------------! @@ -656,9 +658,16 @@ subroutine leaf3_can_diag(ip,can_theta,can_theiv,can_rvap,leaf_class,can_prss,in !---------------------------------------------------------------------------------------! - ! Find the canopy air temperature. + ! If this is the initial step, we initialise the canopy air specific enthalpy. ! + ! Otherwise, we update temperature and potential temperature from enthalpy. ! !---------------------------------------------------------------------------------------! - can_temp = cpi * can_theta * can_exner + if (initial) then + can_temp = extheta2temp(can_exner,can_theta) + can_enthalpy = tq2enthalpy(can_temp,can_shv,.true.) + else + can_temp = hq2temp(can_enthalpy,can_shv,.true.) + can_theta = extemp2theta(can_exner,can_temp) + end if !---------------------------------------------------------------------------------------! @@ -693,7 +702,16 @@ subroutine leaf3_can_diag(ip,can_theta,can_theiv,can_rvap,leaf_class,can_prss,in ! currently a diagnostic variable only, but it should become the main variable if we ! ! ever switch to foggy canopy air space. ! !---------------------------------------------------------------------------------------! - can_theiv = thetaeiv(can_theta,can_prss,can_temp,can_rvap,can_rvap,-84) + can_theiv = thetaeiv(can_theta,can_prss,can_temp,can_rvap,can_rvap) + !---------------------------------------------------------------------------------------! + + + + + !---------------------------------------------------------------------------------------! + ! Find the canopy air space specific heat at constant pressure. ! + !---------------------------------------------------------------------------------------! + can_cp = (1.0 - can_shv) * cpdry + can_shv * cph2o !---------------------------------------------------------------------------------------! @@ -720,7 +738,7 @@ subroutine leaf3_veg_diag(veg_energy,veg_water,veg_hcap) , veg_fliq & ! intent(out) , resolvable ! ! intent(in) use rconstants, only : t3ple ! ! intent(in) - use therm_lib , only : qwtk ! ! function + use therm_lib , only : uextcm2tl ! ! function implicit none !----- Arguments. ----------------------------------------------------------------------! real , intent(inout) :: veg_energy @@ -736,7 +754,7 @@ subroutine leaf3_veg_diag(veg_energy,veg_water,veg_hcap) ! leaves. ! !---------------------------------------------------------------------------------------! if (resolvable) then - call qwtk(veg_energy,veg_water,veg_hcap,veg_temp,veg_fliq) + call uextcm2tl(veg_energy,veg_water,veg_hcap,veg_temp,veg_fliq) else veg_temp = can_temp if (veg_temp > t3ple) then diff --git a/BRAMS/src/surface/leaf3_hyd.f90 b/BRAMS/src/surface/leaf3_hyd.f90 index 4ae453384..61ae531ac 100644 --- a/BRAMS/src/surface/leaf3_hyd.f90 +++ b/BRAMS/src/surface/leaf3_hyd.f90 @@ -114,8 +114,8 @@ subroutine hydrol(m2,m3,mzg,mzs,np,maxpatch,ngrps & ,slz,ig,jg,ipg,lpg,slmsts,zi,fa,wi,finv & ,rhow,rhowi,dtlt,slcons0,slcpd,wateradd,time) -use rconstants, only: cliq,cliqvlme, alli, wdns,wdnsi, tsupercool -use therm_lib, only: qwtk,qtk +use rconstants, only: wdns,wdnsi +use therm_lib, only: uextcm2tl,uint2tl,tl2uint implicit none integer :: m2,m3,mzg,mzs,np,maxpatch,ngrps,ngd,i,j,k,lp,l,ip,nsoil,ibotpatch integer, dimension(*) :: ig,jg,lpg @@ -204,7 +204,7 @@ subroutine hydrol(m2,m3,mzg,mzs,np,maxpatch,ngrps & enddo - call qwtk(energysum,watersum*wdns,slcpdsum,tempktopm,fracliq) + call uextcm2tl(energysum,watersum*wdns,slcpdsum,tempktopm,fracliq) ! If there is no saturated water or if saturated soil is more than half ! frozen, skip over soil hydrology. @@ -242,15 +242,15 @@ subroutine hydrol(m2,m3,mzg,mzs,np,maxpatch,ngrps & if (wateradd(l) .lt. 0.) then ip = ipg(l,ngd) nsoil = nint(soil_text(ksat(l),i,j,ip)) - call qwtk(soil_energy(ksat(l),i,j,ip) & + call uextcm2tl(soil_energy(ksat(l),i,j,ip) & ,soil_water (ksat(l),i,j,ip)*wdns & ,slcpd(nsoil),tempk,fracliq) delta_water = wateradd(l) / (slz(ksat(l)+1) - slz(ksat(l))) soil_water(ksat(l),i,j,ip) = soil_water(ksat(l),i,j,ip) + delta_water - delta_energy = delta_water * cliqvlme * (tempk - tsupercool) + delta_energy = delta_water * wdns * tl2uint(tempk,1.0) soil_energy(ksat(l),i,j,ip) = soil_energy(ksat(l),i,j,ip) + delta_energy wsum = wsum + wateradd(l) * fa(l) - qwsum = qwsum + wateradd(l) * cliqvlme * (tempk - tsupercool) * fa(l) + qwsum = qwsum + wateradd(l) * wdns * tl2uint(tempk,1.0) * fa(l) endif enddo @@ -314,12 +314,12 @@ subroutine hydrol(m2,m3,mzg,mzs,np,maxpatch,ngrps & ip = ipg(l,ngd) if (sfcwater_mass(1,i,j,ip) .gt. 0.) then - call qtk(sfcwater_energy(1,i,j,ip),tempk,fracliq) + call uint2tl(sfcwater_energy(1,i,j,ip),tempk,fracliq) if (fracliq .gt. .1) then qw = sfcwater_energy(1,i,j,ip) * sfcwater_mass(1,i,j,ip) wfreeb = sfcwater_mass(1,i,j,ip) * (fracliq - .1) / 0.9 - qwfree = wfreeb * cliq * (tempk - tsupercool) + qwfree = wfreeb * tl2uint(tempk,1.0) sfcwater_mass(1,i,j,ip) = sfcwater_mass(1,i,j,ip) - wfreeb sfcwater_energy(1,i,j,ip) = (qw - qwfree) & / (max(1.e-4,sfcwater_mass(1,i,j,ip))) diff --git a/BRAMS/src/surface/leaf3_init.f90 b/BRAMS/src/surface/leaf3_init.f90 index 6eb793cbc..6c2dffaff 100644 --- a/BRAMS/src/surface/leaf3_init.f90 +++ b/BRAMS/src/surface/leaf3_init.f90 @@ -641,7 +641,13 @@ subroutine sfcinit_nofile(n1,n2,n3,mzg,mzs,npat,ifm,theta,pi0,pp,rv,co2p,seatp,s use io_params use rconstants use therm_lib , only : reducedpress & ! function - , thetaeiv ! ! function + , thetaeiv & ! function + , press2exner & ! function + , exner2press & ! function + , extheta2temp & ! function + , cmtl2uext & ! function + , tl2uint & ! function + , tq2enthalpy ! ! function implicit none !----- Arguments. ----------------------------------------------------------------------! @@ -776,8 +782,8 @@ subroutine sfcinit_nofile(n1,n2,n3,mzg,mzs,npat,ifm,theta,pi0,pp,rv,co2p,seatp,s jloop: do j = 1,n3 iloop: do i = 1,n2 k2=nint(flpw(i,j)) - piv(i,j) = 0.5 * cpi * (pi0(k2-1,i,j) + pi0(k2,i,j) + pp(k2-1,i,j) + pp(k2,i,j)) - prsv(i,j) = piv(i,j) ** cpor * p00 + piv(i,j) = 0.5 * (pi0(k2-1,i,j) + pi0(k2,i,j) + pp(k2-1,i,j) + pp(k2,i,j)) + prsv(i,j) = exner2press(piv(i,j)) geoht = (zt(k2)-zm(k2-1)) * rtgt(i,j) atm_theta = theta(k2,i,j) @@ -792,12 +798,26 @@ subroutine sfcinit_nofile(n1,n2,n3,mzg,mzs,npat,ifm,theta,pi0,pp,rv,co2p,seatp,s !---------------------------------------------------------------------------------! can_prss(i,j,1) = reducedpress(atm_prss,atm_theta,atm_shv,geoht & ,atm_theta,atm_shv,can_depth) + can_exner = press2exner(can_prss(i,j,1)) can_theta(i,j,1) = theta(k2,i,j) can_rvap(i,j,1) = rv(k2,i,j) + can_shv = can_rvap(i,j,1) / (can_rvap(i,j,1) + 1.) can_co2(i,j,1) = co2p(k2,i,j) - can_temp = theta(k2,i,j) * (p00i * can_prss(i,j,1)) ** rocp + can_temp = extheta2temp(can_exner,atm_theta) can_theiv(i,j,1) = thetaeiv(can_theta(i,j,1),can_prss(i,j,1),can_temp & - ,can_rvap(i,j,1),can_rvap(i,j,1),-91) + ,can_rvap(i,j,1),can_rvap(i,j,1)) + can_enthalpy = tq2enthalpy(can_temp,can_shv,.true.) + !---------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------! + ! Find the temperature immediately above the canopy air space and the ! + ! specific enthalpy associated with it. ! + !---------------------------------------------------------------------------------! + atm_temp_zcan = extheta2temp(can_exner,atm_theta) + atm_enthalpy = tq2enthalpy(atm_temp_zcan,atm_shv,.true.) + !---------------------------------------------------------------------------------! !----- Water patch, so we set vegetation properties to zero. ---------------------! veg_energy(i,j,1) = 0.0 @@ -813,8 +833,8 @@ subroutine sfcinit_nofile(n1,n2,n3,mzg,mzs,npat,ifm,theta,pi0,pp,rv,co2p,seatp,s soil_energy(:,i,j,1) = 0. soil_water (:,i,j,1) = 1. psibar_10d (i,j,1) = 1. - soil_energy(mzg,i,j,1) = cliq * (seatp(i,j) + (seatf(i,j) - seatp(i,j)) & - * timefac_sst - tsupercool) + soil_energy(mzg,i,j,1) = tl2uint( seatp(i,j)+(seatf(i,j)-seatp(i,j))*timefac_sst & + , 1.0) !----- Fluxes. Initially they should be all zero. -------------------------------! sensible_gc (i,j,1) = 0.0 @@ -918,20 +938,22 @@ subroutine sfcinit_nofile(n1,n2,n3,mzg,mzs,npat,ifm,theta,pi0,pp,rv,co2p,seatp,s ! By default, initialize soil internal energy at a temperature equal to ! ! can_temp + stgoff(k). If the temperature is initially below triple ! ! point, we assume all soil water to be frozen, otherwise we assume all ! - ! water to be liquid. ! + ! water to be liquid. If soil temperature is exactly at the triple point, ! + ! assume that the fraction is 50%. ! !---------------------------------------------------------------------------! soil_temp = can_temp + stgoff(k) - if (can_temp >= t3ple) then - soil_energy(k,i,j,ipat) = slcpd(nsoil) * soil_temp & - + soil_water(k,i,j,ipat) & - * cliqvlme * (soil_temp - tsupercool) - soil_fliq = 1.0 + if (soil_temp == t3ple) then + soil_fliq = 0.5 + elseif (soil_temp > t3ple) then + soil_fliq = 1.0 else - soil_energy(k,i,j,ipat) = slcpd(nsoil) * soil_temp & - + soil_water(k,i,j,ipat) * cicevlme * soil_temp - soil_fliq = 0.0 + soil_fliq = 0.0 end if + soil_energy(k,i,j,ipat) = cmtl2uext( slcpd(nsoil) & + , soil_water(k,i,j,ipat) & + , soil_temp,soil_fliq ) + !------ Integrate the relative potential. ----------------------------------! if (k >= kroot(nveg) .and. nsoil /= 13) then psi_layer = slpots(nsoil) & @@ -968,11 +990,11 @@ subroutine sfcinit_nofile(n1,n2,n3,mzg,mzs,npat,ifm,theta,pi0,pp,rv,co2p,seatp,s case (2) sfcwater_depth (1,i,j,ipat) = 6. sfcwater_mass (1,i,j,ipat) = idns * sfcwater_depth(1,i,j,ipat) - sfcwater_energy(1,i,j,ipat) = cice * min(t3ple,can_temp) + sfcwater_energy(1,i,j,ipat) = tl2uint(min(t3ple,can_temp),0.0) case (17,20) sfcwater_depth (1,i,j,ipat) = .1 - sfcwater_mass (1,i,j,ipat) = wdns * sfcwater_depth(1,i,j,ipat) - sfcwater_energy(1,i,j,ipat) = cliq * (max(t3ple,can_temp) -tsupercool) + sfcwater_mass (1,i,j,ipat) = wdns * sfcwater_depth(1,i,j,ipat) + sfcwater_energy(1,i,j,ipat) = tl2uint(max(t3ple,can_temp),1.0) end select !------------------------------------------------------------------------------! diff --git a/BRAMS/src/surface/leaf3_ocean.f90 b/BRAMS/src/surface/leaf3_ocean.f90 index 1fa721788..51f29f34d 100644 --- a/BRAMS/src/surface/leaf3_ocean.f90 +++ b/BRAMS/src/surface/leaf3_ocean.f90 @@ -20,7 +20,8 @@ subroutine leaf3_ocean(mzg,ustar,tstar,rstar,cstar,patch_rough,can_prss,can_rvap , dtlloccc & ! intent(out) , can_depth & ! intent(out) , can_temp & ! intent(out) - , can_lntheta & ! intent(out) + , can_cp & ! intent(out) + , can_enthalpy & ! intent(out) , can_shv & ! intent(out) , veg_temp & ! intent(out) , veg_fliq & ! intent(out) @@ -39,13 +40,11 @@ subroutine leaf3_ocean(mzg,ustar,tstar,rstar,cstar,patch_rough,can_prss,can_rvap , ustmin ! ! intent(in) use rconstants, only : mmdry & ! intent(in) , mmdryi & ! intent(in) - , cp & ! intent(in) - , cpi & ! intent(in) , t3ple & ! intent(in) - , alvl & ! intent(in) , huge_num ! ! intent(in) use therm_lib , only : rslif & ! function - , thetaeiv ! ! function + , thetaeiv & ! function + , tq2enthalpy ! ! function use node_mod , only : mynum ! ! intent(in) implicit none !----- Arguments. ----------------------------------------------------------------------! @@ -74,7 +73,7 @@ subroutine leaf3_ocean(mzg,ustar,tstar,rstar,cstar,patch_rough,can_prss,can_rvap ! fluxes with water surface and atmosphere. ! !---------------------------------------------------------------------------------------! dtllowcc = dtll / (can_depth * can_rhos) - dtllohcc = dtll / (can_depth * can_rhos * cp * can_temp) + dtllohcc = dtll / (can_depth * can_rhos) dtlloccc = mmdry * dtllowcc @@ -101,22 +100,25 @@ subroutine leaf3_ocean(mzg,ustar,tstar,rstar,cstar,patch_rough,can_prss,can_rvap !---------------------------------------------------------------------------------------! !----- Compute the fluxes from water body to canopy. -----------------------------------! - hflxgc = ggnet * cp * can_rhos * (ground_temp - can_temp) - wflxgc = ggnet * can_rhos * (ground_rsat - can_rvap) - qwflxgc = wflxgc * alvl + hflxgc = ggnet * can_cp * can_rhos * (ground_temp - can_temp) + wflxgc = ggnet * can_rhos * (ground_rsat - can_rvap) + qwflxgc = wflxgc * tq2enthalpy(ground_temp,1.0,.true.) cflxgc = 0. !----- No water carbon emission model available... !----- Compute the fluxes from atmosphere to canopy air space. -------------------------! rho_ustar = can_rhos * ustar - eflxac = rho_ustar * estar * cp * can_temp + eflxac = rho_ustar * estar hflxac = rho_ustar * tstar * can_exner wflxac = rho_ustar * rstar cflxac = rho_ustar * cstar * mmdryi + if (can_temp > 310.) then + can_temp = can_temp + 0. + end if !----- Integrate the state variables. --------------------------------------------------! - can_lntheta = can_lntheta + dtllohcc * (hflxgc + hflxac) - can_rvap = can_rvap + dtllowcc * (wflxgc + wflxac) - can_co2 = can_co2 + dtlloccc * (cflxgc + cflxac) + can_enthalpy = can_enthalpy + dtllohcc * (hflxgc + qwflxgc + eflxac) + can_rvap = can_rvap + dtllowcc * (wflxgc + wflxac) + can_co2 = can_co2 + dtlloccc * (cflxgc + cflxac) !----- Integrate the fluxes. -----------------------------------------------------------! sensible_gc = sensible_gc + hflxgc * dtll_factor @@ -140,8 +142,6 @@ end subroutine leaf3_ocean ! future sea surface temperature. ! !------------------------------------------------------------------------------------------! subroutine leaf3_ocean_diag(ifm,mzg,pastsst,futuresst,soil_energy) - use rconstants, only : cliq & ! intent(in) - , tsupercool ! ! intent(in) use mem_grid , only : time ! ! intent(in) use io_params , only : iupdsst & ! intent(in) , ssttime1 & ! intent(in) @@ -149,7 +149,8 @@ subroutine leaf3_ocean_diag(ifm,mzg,pastsst,futuresst,soil_energy) use leaf_coms , only : timefac_sst & ! intent(out) , soil_tempk & ! intent(in) , soil_fracliq ! ! intent(in) - use therm_lib , only : qtk ! ! sub-routine + use therm_lib , only : uint2tl & ! sub-routine + , tl2uint ! ! function implicit none !----- Arguments. ----------------------------------------------------------------------! integer , intent(in) :: ifm @@ -159,8 +160,8 @@ subroutine leaf3_ocean_diag(ifm,mzg,pastsst,futuresst,soil_energy) real , dimension(mzg), intent(inout) :: soil_energy !----- Local variables. ----------------------------------------------------------------! integer :: izg - integer :: sst - integer :: ssq + real :: sst + real :: ssq !---------------------------------------------------------------------------------------! @@ -177,12 +178,12 @@ subroutine leaf3_ocean_diag(ifm,mzg,pastsst,futuresst,soil_energy) !----- Find the sea surface temperature. -----------------------------------------------! sst = pastsst + timefac_sst * (futuresst -pastsst) - ssq = cliq * (sst - tsupercool) + ssq = tl2uint(sst,1.0) !----- Find the sea surface internal energy, assuming that it is always liquid. --------! do izg=1,mzg soil_energy(izg) = ssq - call qtk(soil_energy(izg),soil_tempk(izg),soil_fracliq(izg)) + call uint2tl(soil_energy(izg),soil_tempk(izg),soil_fracliq(izg)) end do !---------------------------------------------------------------------------------------! diff --git a/BRAMS/src/surface/leaf3_tw.f90 b/BRAMS/src/surface/leaf3_tw.f90 index 255984e32..6c3ac1f8b 100644 --- a/BRAMS/src/surface/leaf3_tw.f90 +++ b/BRAMS/src/surface/leaf3_tw.f90 @@ -69,10 +69,10 @@ subroutine leaf3_tw(mzg,mzs,soil_water, soil_energy,soil_text,sfcwater_energy_in use mem_leaf use rconstants use mem_scratch - use therm_lib , only : qwtk & ! subroutine - , qtk & ! subroutine - , hpqz2temp & ! function - , idealdenssh ! ! function + use therm_lib , only : uextcm2tl & ! subroutine + , uint2tl & ! subroutine + , idealdenssh & ! function + , tl2uint ! ! function use catt_start , only : CATT ! ! intent(in) implicit none !----- Arguments -----------------------------------------------------------------------! @@ -164,6 +164,8 @@ subroutine leaf3_tw(mzg,mzs,soil_water, soil_energy,soil_text,sfcwater_energy_in real :: extracted_water real :: wloss real :: qwloss + real :: wlossvlme + real :: qwlossvlme real :: soilcond real :: slz0 real :: ezg @@ -444,7 +446,7 @@ subroutine leaf3_tw(mzg,mzs,soil_water, soil_energy,soil_text,sfcwater_energy_in else w_flux(k) = - min(-w_flux(k),soil_liq(k),half_soilair(k-1)) endif - qw_flux(k) = w_flux(k) * cliqvlme * (soil_tempk(k) - tsupercool) + qw_flux(k) = w_flux(k) * wdns * tl2uint(soil_tempk(k),1.0) end do !---------------------------------------------------------------------------------------! @@ -476,7 +478,7 @@ subroutine leaf3_tw(mzg,mzs,soil_water, soil_energy,soil_text,sfcwater_energy_in end if !------------------------------------------------------------------------------------! end select - qw_flux(1) = w_flux(1) * cliqvlme * (soil_tempk(1) - tsupercool) + qw_flux(1) = w_flux(1) * wdns * tl2uint(soil_tempk(1),1.0) !---------------------------------------------------------------------------------------! @@ -496,11 +498,38 @@ subroutine leaf3_tw(mzg,mzs,soil_water, soil_energy,soil_text,sfcwater_energy_in extracted_water = transp_tot * dtll if (extracted_water > 0. .and. available_water > 0.) then do k = ktrans,mzg - wloss = wdnsi * dslzi(k) * extracted_water * available_layer(k) / available_water - qwloss = wloss * cliqvlme * (soil_tempk(k) - tsupercool) + !---------------------------------------------------------------------------------! + ! Find the loss of water and internal energy from the soil due to ! + ! transpiration. wloss and qwloss are in units of kg/m2 and J/m2, respectively, ! + ! which are consistent with vegetation. ! + !---------------------------------------------------------------------------------! + wloss = extracted_water * available_layer(k) / available_water + qwloss = wloss * tl2uint(soil_tempk(k),1.0) + !---------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------! + ! Wlossvlme and qwlossvlme are in m3/m3 and J/m3, which are consistent with ! + ! soil. ! + !---------------------------------------------------------------------------------! + wlossvlme = wdnsi * dslzi(k) * wloss + qwlossvlme = qwloss * dslzi(k) + !---------------------------------------------------------------------------------! - soil_water(k) = soil_water(k) - wloss - soil_energy(k) = soil_energy(k) - qwloss + + !---------------------------------------------------------------------------------! + ! Remove energy and water from soil. ! + !---------------------------------------------------------------------------------! + soil_water(k) = soil_water(k) - wlossvlme + soil_energy(k) = soil_energy(k) - qwlossvlme + !---------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------! + ! Add the internal energy to the leaves. Water shan't be added because it ! + ! doesn't stay in the leaves, instead it goes to the canopy air space, but that ! + ! was taken care of in leaf3_canopy. ! + !---------------------------------------------------------------------------------! + veg_energy = veg_energy + qwloss + !---------------------------------------------------------------------------------! end do end if !---------------------------------------------------------------------------------------! @@ -526,12 +555,12 @@ subroutine leaf3_tw(mzg,mzs,soil_water, soil_energy,soil_text,sfcwater_energy_in ! Get rid of some liquid water from the top layer through runoff. ! !------------------------------------------------------------------------------------! if (runoff_time > 0.0 .and. sfcwater_mass(ksn) > 0.0) then - call qtk(sfcwater_energy_ext(ksn) / sfcwater_mass(ksn) & - ,sfcwater_tempk(ksn),sfcwater_fracliq(ksn)) + call uint2tl(sfcwater_energy_ext(ksn) / sfcwater_mass(ksn) & + ,sfcwater_tempk(ksn),sfcwater_fracliq(ksn)) wloss = max(0., min(1.0,dtll/runoff_time) & * (sfcwater_mass(ksn) - min_sfcwater_mass) & * (sfcwater_fracliq(ksn) - 0.1) / 0.9) - qwloss = wloss * cliq * (sfcwater_tempk(ksn) - tsupercool) + qwloss = wloss * tl2uint(sfcwater_tempk(ksn),1.0) sfcwater_energy_ext(ksn) = sfcwater_energy_ext(ksn) - qwloss sfcwater_mass(ksn) = sfcwater_mass(ksn) - wloss sfcwater_depth(ksn) = sfcwater_depth(ksn) - wloss * wdnsi @@ -566,8 +595,8 @@ subroutine leaf3_soilsfcw_diag(ip,mzg,mzs,soil_energy,soil_water,soil_text,sfcwa , virtual_energy & ! intent(out) , virtual_water & ! intent(out) , virtual_depth ! ! intent(out) - use therm_lib , only : qwtk & ! sub-routine - , qtk ! ! sub-routine + use therm_lib , only : uextcm2tl & ! sub-routine + , uint2tl ! ! sub-routine use rconstants, only : wdns ! ! intent(in) implicit none !----- Arguments. ----------------------------------------------------------------------! @@ -598,8 +627,8 @@ subroutine leaf3_soilsfcw_diag(ip,mzg,mzs,soil_energy,soil_water,soil_text,sfcwa !----- Find the soil temperature and liquid water fraction. ----------------------------! do k = 1,mzg nsoil = nint(soil_text(k)) - call qwtk(soil_energy(k),soil_water(k)*wdns,slcpd(nsoil) & - ,soil_tempk(k),soil_fracliq(k)) + call uextcm2tl(soil_energy(k),soil_water(k)*wdns,slcpd(nsoil) & + ,soil_tempk(k),soil_fracliq(k)) end do !---------------------------------------------------------------------------------------! @@ -614,7 +643,7 @@ subroutine leaf3_soilsfcw_diag(ip,mzg,mzs,soil_energy,soil_water,soil_text,sfcwa !----- Initial call, find the extensive internal energy from the intensive. ---------! do k=1,ksn sfcwater_energy_ext(k) = sfcwater_energy_int(k) * sfcwater_mass(k) - call qtk(sfcwater_energy_int(k),sfcwater_tempk(k),sfcwater_fracliq(k)) + call uint2tl(sfcwater_energy_int(k),sfcwater_tempk(k),sfcwater_fracliq(k)) end do !----- Fill the layers above with zeroes or dummy values. ---------------------------! if (ksn == 0) then @@ -636,7 +665,7 @@ subroutine leaf3_soilsfcw_diag(ip,mzg,mzs,soil_energy,soil_water,soil_text,sfcwa !----- Convert extensive internal energy into intensive. ----------------------------! do k=1,ksn sfcwater_energy_int(k) = sfcwater_energy_ext(k) / sfcwater_mass(k) - call qtk(sfcwater_energy_int(k),sfcwater_tempk(k),sfcwater_fracliq(k)) + call uint2tl(sfcwater_energy_int(k),sfcwater_tempk(k),sfcwater_fracliq(k)) end do !----- Fill the layers above with zeroes or dummy values. ---------------------------! if (ksn == 0) then @@ -701,12 +730,10 @@ subroutine leaf3_adjust_sfcw(mzg,mzs,soil_energy,soil_water,soil_text,sfcwater_n , newsfcw_depth => vctr18 ! ! intent(out) use rconstants , only : wdns & ! intent(in) , wdnsi & ! intent(in) - , cliq & ! intent(in) - , cice & ! intent(in) - , qliqt3 & ! intent(in) - , tsupercool ! ! intent(in) - use therm_lib , only : qtk & ! sub-routine - , qwtk ! ! sub-routine + , uiliqt3 ! ! intent(in) + use therm_lib , only : uint2tl & ! sub-routine + , uextcm2tl & ! sub-routine + , tl2uint ! ! function implicit none !----- Arguments. ----------------------------------------------------------------------! integer, intent(in) :: mzg @@ -879,7 +906,7 @@ subroutine leaf3_adjust_sfcw(mzg,mzs,soil_energy,soil_water,soil_text,sfcwater_n ! are assuming thermal equilibrium, the temperature and liquid fraction of the ! ! attempted layer is the same as the average temperature of the augmented pool. ! !---------------------------------------------------------------------------------! - call qwtk(energy_tot,wmass_tot,hcapdry_tot,temp_try,fliq_try) + call uextcm2tl(energy_tot,wmass_tot,hcapdry_tot,temp_try,fliq_try) !---------------------------------------------------------------------------------! @@ -888,8 +915,7 @@ subroutine leaf3_adjust_sfcw(mzg,mzs,soil_energy,soil_water,soil_text,sfcwater_n ! and fraction of liquid water distribution we have just found, keeping the mass ! ! constant. ! !---------------------------------------------------------------------------------! - energy_try = wmass_try * ( fliq_try * cliq * (temp_try - tsupercool) & - + (1.0 - fliq_try) * cice * temp_try ) + energy_try = wmass_try * tl2uint(temp_try,fliq_try) !---------------------------------------------------------------------------------! @@ -907,7 +933,7 @@ subroutine leaf3_adjust_sfcw(mzg,mzs,soil_energy,soil_water,soil_text,sfcwater_n ! the attempted layer. ! !---------------------------------------------------------------------------------! i_energy_try = energy_try / wmass_try - call qtk(i_energy_try,temp_try,fliq_try) + call uint2tl(i_energy_try,temp_try,fliq_try) !---------------------------------------------------------------------------------! end if !------------------------------------------------------------------------------------! @@ -973,7 +999,7 @@ subroutine leaf3_adjust_sfcw(mzg,mzs,soil_energy,soil_water,soil_text,sfcwater_n ! Enough mass to keep this layer. ! !---------------------------------------------------------------------------------! !----- Compute the internal energy and depth associated with percolated water. ---! - energy_perc = wmass_perc * cliq * (temp_try - tsupercool) + energy_perc = wmass_perc * tl2uint(temp_try,1.0) depth_perc = wmass_perc * wdnsi !----- Find the new water mass and energy for this layer. ------------------------! sfcwater_mass (k) = wmass_try - wmass_perc @@ -1103,7 +1129,7 @@ subroutine leaf3_adjust_sfcw(mzg,mzs,soil_energy,soil_water,soil_text,sfcwater_n !---------------------------------------------------------------------------------! if ( sfcwater_mass(k) > min_sfcwater_mass .and. & water_stab_thresh * thicknet(k) <= sum_sfcw_mass .and. & - sfcwater_energy_ext(k) < sfcwater_mass(k)*qliqt3 ) then + sfcwater_energy_ext(k) < sfcwater_mass(k)*uiliqt3 ) then newlayers = newlayers + 1 end if !---------------------------------------------------------------------------------! diff --git a/BRAMS/src/surface/leaf3_utils.f90 b/BRAMS/src/surface/leaf3_utils.f90 index 81ed1b3ea..bb8a6a5a1 100644 --- a/BRAMS/src/surface/leaf3_utils.f90 +++ b/BRAMS/src/surface/leaf3_utils.f90 @@ -28,8 +28,8 @@ ! NCAR Technical Note NCAR/TN-461+STR, Boulder, CO, May 2004. ! ! ! !------------------------------------------------------------------------------------------! -subroutine leaf3_stars(theta_atm,theiv_atm,shv_atm,rvap_atm,co2_atm & - ,theta_can,theiv_can,shv_can,rvap_can,co2_can & +subroutine leaf3_stars(theta_atm,enthalpy_atm,shv_atm,rvap_atm,co2_atm & + ,theta_can,enthalpy_can,shv_can,rvap_can,co2_can & ,zref,dheight,uref,dtll,rough,ustar,tstar,estar,qstar,rstar,cstar & ,zeta,rib,r_aer) use mem_leaf , only : istar ! ! intent(in) @@ -54,12 +54,12 @@ subroutine leaf3_stars(theta_atm,theiv_atm,shv_atm,rvap_atm,co2_atm implicit none !----- Arguments -----------------------------------------------------------------------! real, intent(in) :: theta_atm ! Above canopy air pot. temperature [ K] - real, intent(in) :: theiv_atm ! Above canopy air eq. pot. temp [ K] + real, intent(in) :: enthalpy_atm ! Above canopy air specific enthalpy [ J/kg] real, intent(in) :: shv_atm ! Above canopy vapour spec. hum. [kg/kg_air] real, intent(in) :: rvap_atm ! Above canopy vapour mixing ratio [kg/kg_air] real, intent(in) :: co2_atm ! Above canopy CO2 mixing ratio [ µmol/mol] real, intent(in) :: theta_can ! Canopy air potential temperature [ K] - real, intent(in) :: theiv_can ! Canopy air equiv. potential temperature [ K] + real, intent(in) :: enthalpy_can ! Canopy air specific enthalpy [ J/kg] real, intent(in) :: shv_can ! Canopy air vapour spec. humidity [kg/kg_air] real, intent(in) :: rvap_can ! Canopy air vapour mixing ratio [kg/kg_air] real, intent(in) :: co2_can ! Canopy air CO2 mixing ratio [ µmol/mol] @@ -307,11 +307,11 @@ subroutine leaf3_stars(theta_atm,theiv_atm,shv_atm,rvap_atm,co2_atm end select !----- Finding all stars. --------------------------------------------------------------! - tstar = c3 * (theta_atm - theta_can) - estar = c3 * log(theiv_atm / theiv_can) - qstar = c3 * (shv_atm - shv_can ) - rstar = c3 * (rvap_atm - rvap_can ) - cstar = c3 * (co2_atm - co2_can ) + tstar = c3 * (theta_atm - theta_can ) + estar = c3 * (enthalpy_atm - enthalpy_can) + qstar = c3 * (shv_atm - shv_can ) + rstar = c3 * (rvap_atm - rvap_can ) + cstar = c3 * (co2_atm - co2_can ) if (abs(tstar) < 1.e-7) tstar = 0. if (abs(estar) < 1.e-7) estar = 0. @@ -489,8 +489,8 @@ subroutine leaf3_grndvap(topsoil_energy,topsoil_water,topsoil_text,sfcwater_ener , lnexp_min & ! intent(in) , huge_num ! ! intent(in) use therm_lib , only : rslif & ! function - , qwtk & ! function - , qtk ! ! function + , uextcm2tl & ! function + , uint2tl ! ! function use mem_leaf , only : igrndvap ! ! intent(in) implicit none @@ -537,7 +537,7 @@ subroutine leaf3_grndvap(topsoil_energy,topsoil_water,topsoil_text,sfcwater_ener ! determined by the alpha and beta parameters. ! !------------------------------------------------------------------------------------! nsoil = nint(topsoil_text) - call qwtk(topsoil_energy,topsoil_water*wdns,slcpd(nsoil),ground_temp,ground_fliq) + call uextcm2tl(topsoil_energy,topsoil_water*wdns,slcpd(nsoil),ground_temp,ground_fliq) !----- Compute the saturation mixing ratio at ground temperature. -------------------! ground_rsat = rslif(can_prss,ground_temp) !------------------------------------------------------------------------------------! @@ -620,7 +620,7 @@ subroutine leaf3_grndvap(topsoil_energy,topsoil_water,topsoil_text,sfcwater_ener ! is "pure" water or snow, we let it evaporate freely. We can understand this as ! ! the limit of alpha and beta tending to one. ! !------------------------------------------------------------------------------------! - call qtk(sfcwater_energy_int,ground_temp,ground_fliq) + call uint2tl(sfcwater_energy_int,ground_temp,ground_fliq) !----- Compute the saturation specific humidity at ground temperature. --------------! ground_rsat = rslif(can_prss,ground_temp) !----- The ground specific humidity in this case is just the saturation value. ------! @@ -841,16 +841,14 @@ end subroutine sfc_fields_adap !==========================================================================================! subroutine sfc_pcp(m2,m3,mcld,ia,iz,ja,jz,dtime,dtime_factor,theta2,exner2,conprr,bulkpcpg & ,bulkqpcpg,bulkdpcpg,leafpcpg,leafqpcpg,leafdpcpg) - use rconstants, only : cice & ! intent(in) - , cliq & ! intent(in) - , cpi & ! intent(in) - , tsupercool & ! intent(in) - , t3ple & ! intent(in) - , t00 & ! intent(in) - , hr_sec & ! intent(in) - , wdnsi ! ! intent(in) - use node_mod , only : mynum ! ! intent(in) - use grid_dims , only : str_len ! ! intent(in) + use rconstants, only : t3ple & ! intent(in) + , t00 & ! intent(in) + , hr_sec & ! intent(in) + , wdnsi ! ! intent(in) + use node_mod , only : mynum ! ! intent(in) + use grid_dims , only : str_len ! ! intent(in) + use therm_lib , only : tl2uint & ! function + , extheta2temp ! ! function implicit none !----- Arguments. ----------------------------------------------------------------------! integer , intent(in) :: m2 @@ -920,7 +918,7 @@ subroutine sfc_pcp(m2,m3,mcld,ia,iz,ja,jz,dtime,dtime_factor,theta2,exner2,conpr iloop: do i=ia,iz !----- Estimate the precipitation temperature. -----------------------------------! - rain_temp = cpi * theta2(i,j) * exner2(i,j) + rain_temp = extheta2temp(exner2(i,j),theta2(i,j)) !----- Integrate precipitation rate. ---------------------------------------------! @@ -978,8 +976,8 @@ subroutine sfc_pcp(m2,m3,mcld,ia,iz,ja,jz,dtime,dtime_factor,theta2,exner2,conpr ! fraction plus the specific internal energy of ice (below or at the triple ! ! point) multiplied by the ice fraction. ! !---------------------------------------------------------------------------------! - cumqpcpg = cumpcpg * ( (1.0-fice) * cliq * ( max(t3ple,rain_temp) - tsupercool) & - + fice * cice * min(rain_temp,t3ple) ) + cumqpcpg = cumpcpg * ( (1.0-fice) * tl2uint(max(t3ple,rain_temp),1.0) & + + fice * tl2uint(min(rain_temp,t3ple),0.0) ) !---------------------------------------------------------------------------------! @@ -1221,8 +1219,7 @@ subroutine leaf3_sfcrad(mzg,mzs,ip,soil_water,soil_color,soil_text,sfcwater_dept use rconstants use mem_scratch use node_mod , only : mynum ! ! intent(in) - use therm_lib , only : qwtk & ! subroutine - , qtk & ! subroutine + use therm_lib , only : uextcm2tl & ! subroutine , idealdenssh ! ! function use catt_start , only : CATT ! ! intent(in) use teb_spm_start, only : TEB_SPM ! ! intent(in) @@ -1591,7 +1588,8 @@ end function leaf3_reduced_wind ! - gbh is in J/(K m2 s), and ! ! - gbw is in kg_H2O/m2/s. ! !------------------------------------------------------------------------------------------! -subroutine leaf3_aerodynamic_conductances(iveg,veg_wind,veg_temp,can_temp,can_shv,can_rhos) +subroutine leaf3_aerodynamic_conductances(iveg,veg_wind,veg_temp,can_temp,can_shv,can_rhos & + ,can_cp) use leaf_coms , only : leaf_width & ! intent(in) , aflat_turb & ! intent(in) , aflat_lami & ! intent(in) @@ -1606,8 +1604,7 @@ subroutine leaf3_aerodynamic_conductances(iveg,veg_wind,veg_temp,can_temp,can_sh , gbw ! ! intent(in) use rconstants, only : gr_coeff & ! intent(in) , th_diffi & ! intent(in) - , th_diff & ! intent(in) - , cp ! ! intent(in) + , th_diff ! ! intent(in) implicit none !----- Arguments. ----------------------------------------------------------------------! integer :: iveg ! Vegetation class [ ---] @@ -1616,6 +1613,7 @@ subroutine leaf3_aerodynamic_conductances(iveg,veg_wind,veg_temp,can_temp,can_sh real(kind=4) , intent(in) :: can_temp ! Canopy air temperature [ K] real(kind=4) , intent(in) :: can_shv ! Canopy air spec. hum. [ kg/kg] real(kind=4) , intent(in) :: can_rhos ! Canopy air density [ kg/m³] + real(kind=4) , intent(in) :: can_cp ! Canopy air spec. heat [ J/kg/K] !----- Local variables. ----------------------------------------------------------------! real(kind=4) :: lwidth ! Leaf width [ m] real(kind=4) :: grashof ! Grashof number [ ---] @@ -1675,7 +1673,7 @@ subroutine leaf3_aerodynamic_conductances(iveg,veg_wind,veg_temp,can_temp,can_sh ! water fluxes [J/K/m²/s and kg/m²/s, respectively]. ! !---------------------------------------------------------------------------------------! gbh_mos = free_gbh_mos + forced_gbh_mos - gbh = gbh_mos * can_rhos * cp + gbh = gbh_mos * can_rhos * can_cp gbw = gbh_2_gbw * gbh_mos * can_rhos !---------------------------------------------------------------------------------------! @@ -1694,32 +1692,31 @@ end subroutine leaf3_aerodynamic_conductances ! This sub-routine copies some atmospheric fields from the 2-D arrays to the common ! ! module variable. ! !------------------------------------------------------------------------------------------! -subroutine leaf3_atmo1d(m2,m3,i,j,thp,theta,rv,rtp,co2p,up,vp,pitot,dens,height,pcpg,qpcpg & - ,dpcpg) - use leaf_coms , only : ubmin & ! intent(in) - , atm_up & ! intent(out) - , atm_vp & ! intent(out) - , atm_thil & ! intent(out) - , atm_theta & ! intent(out) - , atm_rvap & ! intent(out) - , atm_rtot & ! intent(out) - , atm_shv & ! intent(out) - , geoht & ! intent(out) - , atm_exner & ! intent(out) - , atm_co2 & ! intent(out) - , atm_prss & ! intent(out) - , atm_rhos & ! intent(out) - , atm_vels & ! intent(out) - , atm_temp & ! intent(out) - , atm_theiv & ! intent(out) - , pcpgl & ! intent(out) - , qpcpgl & ! intent(out) - , dpcpgl ! ! intent(out) - use rconstants, only : srtwo & ! intent(in) - , cpi & ! intent(in) - , p00 & ! intent(in) - , cpor ! ! intent(in) - use therm_lib , only : thetaeiv ! ! function +subroutine leaf3_atmo1d(m2,m3,i,j,thp,theta,rv,rtp,co2p,up,vp,pitot,dens,height & + ,pcpg,qpcpg,dpcpg) + use leaf_coms , only : ubmin & ! intent(in) + , atm_up & ! intent(out) + , atm_vp & ! intent(out) + , atm_thil & ! intent(out) + , atm_theta & ! intent(out) + , atm_rvap & ! intent(out) + , atm_rtot & ! intent(out) + , atm_shv & ! intent(out) + , geoht & ! intent(out) + , atm_exner & ! intent(out) + , atm_co2 & ! intent(out) + , atm_prss & ! intent(out) + , atm_rhos & ! intent(out) + , atm_vels & ! intent(out) + , atm_temp & ! intent(out) + , atm_theiv & ! intent(out) + , pcpgl & ! intent(out) + , qpcpgl & ! intent(out) + , dpcpgl ! ! intent(out) + use rconstants, only : srtwo ! ! intent(in) + use therm_lib , only : thetaeiv & ! function + , exner2press & ! function + , extheta2temp ! ! function implicit none !----- Arguments. ----------------------------------------------------------------------! @@ -1743,6 +1740,7 @@ subroutine leaf3_atmo1d(m2,m3,i,j,thp,theta,rv,rtp,co2p,up,vp,pitot,dens,height, !----- Local variables. ----------------------------------------------------------------! real :: wfact real :: vels_1st + real :: tmp !---------------------------------------------------------------------------------------! @@ -1770,9 +1768,9 @@ subroutine leaf3_atmo1d(m2,m3,i,j,thp,theta,rv,rtp,co2p,up,vp,pitot,dens,height, geoht = height(i,j) atm_exner = pitot(i,j) atm_co2 = co2p(i,j) - atm_prss = p00 * (cpi * atm_exner) ** cpor - atm_temp = cpi * atm_theta * atm_exner - atm_theiv = thetaeiv(atm_thil,atm_prss,atm_temp,atm_rvap,atm_rtot,-67) + atm_prss = exner2press(atm_exner) + atm_temp = extheta2temp(atm_exner,atm_theta) + atm_theiv = thetaeiv(atm_thil,atm_prss,atm_temp,atm_rvap,atm_rtot) pcpgl = pcpg(i,j) qpcpgl = qpcpg(i,j) dpcpgl = dpcpg(i,j) @@ -1810,19 +1808,19 @@ subroutine leaf0(m2,m3,mpat,i,j,can_theta,can_rvap,can_co2,can_prss,can_theiv,pa , can_rhv & ! intent(out) , can_exner & ! intent(out) , can_temp & ! intent(out) - , can_lntheta & ! intent(out) - , can_rhos ! ! intent(out) - use rconstants, only : cp & ! intent(in) - , cpi & ! intent(in) - , ep & ! intent(in) - , p00 & ! intent(in) - , p00i & ! intent(in) - , rocp & ! intent(in) - , cpor ! ! intent(in) + , can_enthalpy & ! intent(out) + , can_rhos & ! intent(out) + , can_cp ! ! intent(out) + use rconstants, only : ep & ! intent(in) + , cpdry & ! intent(in) + , cph2o ! ! intent(in) use therm_lib , only : thetaeiv & ! function , rslif & ! function , reducedpress & ! function - , idealdenssh ! ! function + , idealdenssh & ! function + , press2exner & ! function + , extheta2temp & ! function + , tq2enthalpy ! ! function implicit none !----- Arguments. ----------------------------------------------------------------------! @@ -1851,8 +1849,8 @@ subroutine leaf0(m2,m3,mpat,i,j,can_theta,can_rvap,can_co2,can_prss,can_theiv,pa can_prss(i,j,2) = reducedpress(atm_prss,atm_theta,atm_shv,geoht,can_theta(i,j,2) & ,can_shv,can_depth_min) - can_exner = cp * (p00i * can_prss(i,j,2)) ** rocp - can_temp = cpi * can_theta(i,j,2) * can_exner + can_exner = press2exner(can_prss(i,j,2)) + can_temp = extheta2temp(can_exner,can_theta(i,j,2)) can_rsat = rslif(can_prss(i,j,2),can_temp) @@ -1860,10 +1858,11 @@ subroutine leaf0(m2,m3,mpat,i,j,can_theta,can_rvap,can_co2,can_prss,can_theiv,pa / ( can_rsat * (ep + can_rvap(i,j,2))) can_theiv(i,j,2) = thetaeiv(can_theta(i,j,2),can_prss(i,j,2),can_temp,can_rvap(i,j,2) & - ,can_rvap(i,j,2),-26) + ,can_rvap(i,j,2)) - can_lntheta = log(can_theta(i,j,2)) + can_enthalpy = tq2enthalpy(can_temp,can_shv,.true.) can_rhos = idealdenssh(can_prss(i,j,2),can_temp,can_shv) + can_cp = (1.0 - can_shv) * cpdry + can_shv * cph2o !---------------------------------------------------------------------------------------! @@ -2105,17 +2104,19 @@ end subroutine leaf3_solve_veg !------------------------------------------------------------------------------------------! subroutine update_psibar(m2,m3,mzg,npat,ia,iz,ja,jz,dtime,soil_energy,soil_water,soil_text & ,leaf_class,psibar_10d) - use therm_lib , only : qwtk ! ! subroutine - use mem_leaf , only : slz & ! intent(in) - , dtleaf ! ! intent(in) - use leaf_coms , only : slpots & ! intent(in) - , slbs & ! intent(in) - , slcpd & ! intent(in) - , kroot & ! intent(in) - , psild & ! intent(in) - , psiwp ! ! intent(in) - use rconstants, only : wdns & ! intent(in) - , day_sec ! ! intent(in) + use therm_lib , only : uextcm2tl ! ! subroutine + use mem_leaf , only : slz & ! intent(in) + , dtleaf ! ! intent(in) + use leaf_coms , only : slzt & ! intent(in) + , slmsts & ! intent(in) + , slpots & ! intent(in) + , slbs & ! intent(in) + , slcpd & ! intent(in) + , kroot & ! intent(in) + , psild & ! intent(in) + , psiwp ! ! intent(in) + use rconstants, only : wdns & ! intent(in) + , day_sec ! ! intent(in) implicit none !----- Arguments. ----------------------------------------------------------------------! integer , intent(in) :: m2 @@ -2141,6 +2142,7 @@ subroutine update_psibar(m2,m3,mzg,npat,ia,iz,ja,jz,dtime,soil_energy,soil_water integer :: nveg real :: available_water real :: psi_layer + real :: wgpfrac real :: soil_temp real :: soil_fliq real :: weight @@ -2165,11 +2167,19 @@ subroutine update_psibar(m2,m3,mzg,npat,ia,iz,ja,jz,dtime,soil_energy,soil_water if (nsoil /= 13) then !----- Find the liquid fraction, which will scale available water. ------! - call qwtk(soil_energy(k,i,j,ip),soil_water(k,i,j,ip)*wdns,slcpd(nsoil) & - ,soil_temp,soil_fliq) + call uextcm2tl(soil_energy(k,i,j,ip),soil_water(k,i,j,ip)*wdns & + ,slcpd(nsoil),soil_temp,soil_fliq) !------------------------------------------------------------------------! + + !----- Find the water potential of this layer. --------------------------! + wgpfrac = min(soil_water(k,i,j,ip)/slmsts(nsoil), 1.0) + psi_layer = slzt(k) + slpots(nsoil) / wgpfrac ** slbs(nsoil) + !------------------------------------------------------------------------! + + + !----- Add the contribution of this layer, based on the potential. ------! available_water = available_water & + max(0., (psi_layer - psiwp(nsoil)) & @@ -2177,6 +2187,7 @@ subroutine update_psibar(m2,m3,mzg,npat,ia,iz,ja,jz,dtime,soil_energy,soil_water * soil_fliq * (slz(k+1)-slz(k)) !------------------------------------------------------------------------! end if + !---------------------------------------------------------------------------! end do !------------------------------------------------------------------------------! diff --git a/BRAMS/src/surface/leaf_coms.f90 b/BRAMS/src/surface/leaf_coms.f90 index 423075e2c..c41acb58c 100644 --- a/BRAMS/src/surface/leaf_coms.f90 +++ b/BRAMS/src/surface/leaf_coms.f90 @@ -21,7 +21,7 @@ module leaf_coms use grid_dims use rconstants, only: grav & ! intent(in) , vonk & ! intent(in) - , alvl & ! intent(in) + , alvl3 & ! intent(in) , onethird & ! intent(in) , twothirds ! ! intent(in) @@ -50,7 +50,7 @@ module leaf_coms real :: dtll & ! leaf timestep , dtll_factor & ! leaf timestep factor (leaf timestep / model timestep) , dtllowcc & ! leaf timestep / (can_depth * can_rhos) - , dtllohcc & ! leaf timestep / (can_depth * can_rhos * cp * can_temp) + , dtllohcc & ! leaf timestep / (can_depth * can_rhos) , dtlloccc & ! mmdry * leaf timestep / (can_depth * can_rhos) , atm_up & ! U velocity at top of surface layer [ m/s] @@ -58,6 +58,8 @@ module leaf_coms , atm_thil & ! ice-liquid pot. temp. at top of surface layer [ K] , atm_theta & ! potential temperature at top of surface layer [ K] , atm_temp & ! temperature at top of surface layer [ K] + , atm_temp_zcan & ! air temperature just above the canopy air [ K] + , atm_enthalpy & ! specific enthalpy above the canopy air space [ J/kg] , atm_rvap & ! vapor mixing ratio at top of surface layer [ kg/kg] , atm_rtot & ! total mixing ratio at top of surface layer [ kg/kg] , atm_shv & ! specific humidity at top of surface layer [ kg/kg] @@ -75,7 +77,8 @@ module leaf_coms , snowfac & ! frac. of veg. height covered by sfcwater [ ---] , can_exner & ! canopy air Exner function [ J/kg/K] , can_temp & ! canopy air temperature [ K] - , can_lntheta & ! log of canopy air potential temperature [ ---] + , can_enthalpy & ! canopy air specific enthalpy [ J/kg] + , can_cp & ! canopy air specific heat at constant pressure [ J/kg/K] , can_rhos & ! canopy air density [ kg/m³] , can_rsat & ! canopy air saturation mixing ratio [ kg/kg] , can_shv & ! canopy air specific humidity [ kg/kg] @@ -236,7 +239,7 @@ module leaf_coms !---------------------------------------------------------------------------------------! !----- Maximum transpiration allowed. --------------------------------------------------! - real, parameter :: transp_max = 400. / alvl + real, parameter :: transp_max = 400. / alvl3 !---------------------------------------------------------------------------------------! !----- Is super-saturation fine? -------------------------------------------------------! @@ -585,7 +588,7 @@ subroutine flush_leaf_coms(idel) case ('INITIAL','GRID_POINT','PATCH') resolvable = .false. - can_lntheta = 0. + can_enthalpy = 0. can_exner = 0 can_rhos = 0. can_depth = 0. @@ -606,6 +609,7 @@ subroutine flush_leaf_coms(idel) dtlloccc = 0. snowfac = 0. + can_cp = 0. can_temp = 0 can_rsat = 0. can_shv = 0. diff --git a/BRAMS/src/surface/mem_leaf.f90 b/BRAMS/src/surface/mem_leaf.f90 index 482830223..f05bac8af 100644 --- a/BRAMS/src/surface/mem_leaf.f90 +++ b/BRAMS/src/surface/mem_leaf.f90 @@ -319,79 +319,79 @@ subroutine nullify_leaf(leaf) !------------------------------------------------------------------------------------! - if (associated(leaf%soil_water )) nullify(leaf%soil_water ) - if (associated(leaf%soil_energy )) nullify(leaf%soil_energy ) - if (associated(leaf%soil_text )) nullify(leaf%soil_text ) - if (associated(leaf%soil_rough )) nullify(leaf%soil_rough ) - if (associated(leaf%soil_color )) nullify(leaf%soil_color ) - - if (associated(leaf%sfcwater_mass )) nullify(leaf%sfcwater_mass ) - if (associated(leaf%sfcwater_energy )) nullify(leaf%sfcwater_energy ) - if (associated(leaf%sfcwater_depth )) nullify(leaf%sfcwater_depth ) - if (associated(leaf%sfcwater_nlev )) nullify(leaf%sfcwater_nlev ) - - if (associated(leaf%ground_rsat )) nullify(leaf%ground_rsat ) - if (associated(leaf%ground_rvap )) nullify(leaf%ground_rvap ) - if (associated(leaf%ground_temp )) nullify(leaf%ground_temp ) - if (associated(leaf%ground_fliq )) nullify(leaf%ground_fliq ) - - if (associated(leaf%veg_fracarea )) nullify(leaf%veg_fracarea ) - if (associated(leaf%veg_lai )) nullify(leaf%veg_lai ) - if (associated(leaf%veg_agb )) nullify(leaf%veg_agb ) - if (associated(leaf%veg_rough )) nullify(leaf%veg_rough ) - if (associated(leaf%veg_height )) nullify(leaf%veg_height ) - if (associated(leaf%veg_displace )) nullify(leaf%veg_displace ) - if (associated(leaf%veg_albedo )) nullify(leaf%veg_albedo ) - if (associated(leaf%veg_tai )) nullify(leaf%veg_tai ) - if (associated(leaf%veg_water )) nullify(leaf%veg_water ) - if (associated(leaf%veg_hcap )) nullify(leaf%veg_hcap ) - if (associated(leaf%veg_energy )) nullify(leaf%veg_energy ) - if (associated(leaf%veg_ndvip )) nullify(leaf%veg_ndvip ) - if (associated(leaf%veg_ndvic )) nullify(leaf%veg_ndvic ) - if (associated(leaf%veg_ndvif )) nullify(leaf%veg_ndvif ) - if (associated(leaf%leaf_class )) nullify(leaf%leaf_class ) - if (associated(leaf%stom_condct )) nullify(leaf%stom_condct ) - - if (associated(leaf%can_rvap )) nullify(leaf%can_rvap ) - if (associated(leaf%can_theta )) nullify(leaf%can_theta ) - if (associated(leaf%can_theiv )) nullify(leaf%can_theiv ) - if (associated(leaf%can_prss )) nullify(leaf%can_prss ) - if (associated(leaf%can_co2 )) nullify(leaf%can_co2 ) - - if (associated(leaf%ustar )) nullify(leaf%ustar ) - if (associated(leaf%tstar )) nullify(leaf%tstar ) - if (associated(leaf%estar )) nullify(leaf%estar ) - if (associated(leaf%rstar )) nullify(leaf%rstar ) - if (associated(leaf%cstar )) nullify(leaf%cstar ) - - if (associated(leaf%zeta )) nullify(leaf%zeta ) - if (associated(leaf%ribulk )) nullify(leaf%ribulk ) - - if (associated(leaf%patch_area )) nullify(leaf%patch_area ) - if (associated(leaf%patch_rough )) nullify(leaf%patch_rough ) - if (associated(leaf%patch_wetind )) nullify(leaf%patch_wetind ) - - - if (associated(leaf%gpp )) nullify(leaf%gpp ) - if (associated(leaf%resphet )) nullify(leaf%resphet ) - if (associated(leaf%plresp )) nullify(leaf%plresp ) - if (associated(leaf%evap_gc )) nullify(leaf%evap_gc ) - if (associated(leaf%evap_vc )) nullify(leaf%evap_vc ) - if (associated(leaf%transp )) nullify(leaf%transp ) - if (associated(leaf%sensible_gc )) nullify(leaf%sensible_gc ) - if (associated(leaf%sensible_vc )) nullify(leaf%sensible_vc ) - if (associated(leaf%psibar_10d )) nullify(leaf%psibar_10d ) - - if (associated(leaf%rshort_gnd )) nullify(leaf%rshort_gnd ) - if (associated(leaf%rlong_gnd )) nullify(leaf%rlong_gnd ) - - if (associated(leaf%R_aer )) nullify(leaf%R_aer ) - if (associated(leaf%G_URBAN )) nullify(leaf%G_URBAN ) - - if (associated(leaf%snow_mass )) nullify(leaf%snow_mass ) - if (associated(leaf%snow_depth )) nullify(leaf%snow_depth ) - if (associated(leaf%seatp )) nullify(leaf%seatp ) - if (associated(leaf%seatf )) nullify(leaf%seatf ) + nullify(leaf%soil_water ) + nullify(leaf%soil_energy ) + nullify(leaf%soil_text ) + nullify(leaf%soil_rough ) + nullify(leaf%soil_color ) + + nullify(leaf%sfcwater_mass ) + nullify(leaf%sfcwater_energy ) + nullify(leaf%sfcwater_depth ) + nullify(leaf%sfcwater_nlev ) + + nullify(leaf%ground_rsat ) + nullify(leaf%ground_rvap ) + nullify(leaf%ground_temp ) + nullify(leaf%ground_fliq ) + + nullify(leaf%veg_fracarea ) + nullify(leaf%veg_lai ) + nullify(leaf%veg_agb ) + nullify(leaf%veg_rough ) + nullify(leaf%veg_height ) + nullify(leaf%veg_displace ) + nullify(leaf%veg_albedo ) + nullify(leaf%veg_tai ) + nullify(leaf%veg_water ) + nullify(leaf%veg_hcap ) + nullify(leaf%veg_energy ) + nullify(leaf%veg_ndvip ) + nullify(leaf%veg_ndvic ) + nullify(leaf%veg_ndvif ) + nullify(leaf%leaf_class ) + nullify(leaf%stom_condct ) + + nullify(leaf%can_rvap ) + nullify(leaf%can_theta ) + nullify(leaf%can_theiv ) + nullify(leaf%can_prss ) + nullify(leaf%can_co2 ) + + nullify(leaf%ustar ) + nullify(leaf%tstar ) + nullify(leaf%estar ) + nullify(leaf%rstar ) + nullify(leaf%cstar ) + + nullify(leaf%zeta ) + nullify(leaf%ribulk ) + + nullify(leaf%patch_area ) + nullify(leaf%patch_rough ) + nullify(leaf%patch_wetind ) + + + nullify(leaf%gpp ) + nullify(leaf%resphet ) + nullify(leaf%plresp ) + nullify(leaf%evap_gc ) + nullify(leaf%evap_vc ) + nullify(leaf%transp ) + nullify(leaf%sensible_gc ) + nullify(leaf%sensible_vc ) + nullify(leaf%psibar_10d ) + + nullify(leaf%rshort_gnd ) + nullify(leaf%rlong_gnd ) + + nullify(leaf%R_aer ) + nullify(leaf%G_URBAN ) + + nullify(leaf%snow_mass ) + nullify(leaf%snow_depth ) + nullify(leaf%seatp ) + nullify(leaf%seatf ) return end subroutine nullify_leaf diff --git a/BRAMS/src/surface/ruser.f90 b/BRAMS/src/surface/ruser.f90 index 2509967c5..963ba8901 100644 --- a/BRAMS/src/surface/ruser.f90 +++ b/BRAMS/src/surface/ruser.f90 @@ -371,7 +371,10 @@ subroutine sfcinit_nofile_user(n1,n2,n3,mzg,mzs,npat,ifm,theta,pi0,pp,rv,co2p,so use io_params use rconstants use therm_lib , only : reducedpress & ! function - , thetaeiv ! ! function + , thetaeiv & ! function + , tl2uint & ! function + , cmtl2uext & ! function + , exner2press ! ! function implicit none !----- Arguments. ----------------------------------------------------------------------! @@ -464,7 +467,8 @@ subroutine sfcinit_nofile_user(n1,n2,n3,mzg,mzs,npat,ifm,theta,pi0,pp,rv,co2p,so integer :: ipat integer :: nveg integer :: nsoil - real :: tsoil + real :: soil_temp + real :: soil_fliq !---------------------------------------------------------------------------------------! ! select case (ifm) @@ -480,9 +484,8 @@ subroutine sfcinit_nofile_user(n1,n2,n3,mzg,mzs,npat,ifm,theta,pi0,pp,rv,co2p,so ! jloop: do j = 1,n3 ! iloop: do i = 1,n2 ! k2=nint(flpw(i,j)) - ! piv(i,j) = 0.5 * cpi * (pi0(k2-1,i,j) + pi0(k2,i,j) & - ! + pp(k2-1,i,j) + pp(k2,i,j)) - ! prsv(i,j) = piv(i,j) ** cpor * p00 + ! piv(i,j) = 0.5 * (pi0(k2-1,i,j) + pi0(k2,i,j) + pp(k2-1,i,j) + pp(k2,i,j)) + ! prsv(i,j) = exner2press(piv(i,j)) ! geoht = (zt(k2)-zm(k2-1)) * rtgt(i,j) ! atm_shv = rv(k2,i,j) / (rv(k2,i,j) + 1.) @@ -498,7 +501,8 @@ subroutine sfcinit_nofile_user(n1,n2,n3,mzg,mzs,npat,ifm,theta,pi0,pp,rv,co2p,so ! can_theta(i,j,1) = theta(k2,i,j) ! can_rvap(i,j,1) = rv(k2,i,j) ! can_co2(i,j,1) = co2p(k2,i,j) - ! can_temp = theta(k2,i,j) * (p00i * can_prss(i,j,1)) ** rocp + ! can_exner = press2exner(can_prss(i,j,1)) + ! can_temp = extheta2temp(can_exner,theta(k2,i,j)) ! can_theiv(i,j,1) = thetaeiv(can_theta(i,j,1),can_prss(i,j,1),can_temp & ! ,can_rvap(i,j,1),can_rvap(i,j,1),-91) @@ -513,8 +517,9 @@ subroutine sfcinit_nofile_user(n1,n2,n3,mzg,mzs,npat,ifm,theta,pi0,pp,rv,co2p,so ! !-----------------------------------------------------------------------------! ! soil_energy(:,i,j,1) = 0. ! soil_water (:,i,j,1) = 1. - ! soil_energy(mzg,i,j,1) = cliq * (seatp(i,j) + (seatf(i,j) - seatp(i,j)) & - ! * timefac_sst - tsupercool) + ! soil_energy(mzg,i,j,1) = tl2uint( seatp(i,j) & + ! + (seatf(i,j) - seatp(i,j))* timefac_sst, 1.0) + ! !-----------------------------------------------------------------------------! ! !----- Fluxes. Initially they should be all zero. ---------------------------! ! sensible_gc (i,j,1) = 0.0 @@ -585,20 +590,24 @@ subroutine sfcinit_nofile_user(n1,n2,n3,mzg,mzs,npat,ifm,theta,pi0,pp,rv,co2p,so ! soil_water(k,i,j,ipat) = ! end select - ! !---------------------------------------------------------------------------! - ! ! By default, initialize soil internal energy at a temperature equal to ! - ! ! can_temp + stgoff(k). If the temperature is initially below triple ! - ! ! point, we assume all soil water to be frozen, otherwise we assume all ! - ! ! water to be liquid. ! - ! !---------------------------------------------------------------------------! - ! tsoil = can_temp + stgoff(k) - ! if (can_temp >= t3ple) then - ! soil_energy(k,i,j,ipat) = slcpd(nsoil) * tsoil + soil_water(k,i,j,ipat) & - ! * cliqvlme * (tsoil - tsupercool) + ! !-----------------------------------------------------------------------! + ! ! By default, initialize soil internal energy at a temperature ! + ! ! equal to can_temp + stgoff(k). If the temperature is initially below ! + ! ! triple point, we assume all soil water to be frozen, otherwise we ! + ! ! assume all water to be liquid. At the triple point, we assume that ! + ! ! the liquid fraction is 50%. ! + ! !-----------------------------------------------------------------------! + ! soil_temp = can_temp + stgoff(k) + ! if (soil_temp == t3ple) then + ! soil_fliq = 0.5 + ! elseif (soil_temp > t3ple) then + ! soil_fliq = 1.0 ! else - ! soil_energy(k,i,j,ipat) = clcpd(nsoil) * tsoil & - ! + soil_water(k,i,j,ipat) * cicevlme * tsoil + ! soil_fliq = 0.0 ! end if + ! soil_energy(k,i,j,ipat) = cmtl2uext( slcpd(nsoil) & + ! , soil_water(k,i,j,ipat) & + ! , soil_temp,soil_fliq) ! end do ! !------ Surface water, if any, will initially occupy just the first level. ----! @@ -621,11 +630,11 @@ subroutine sfcinit_nofile_user(n1,n2,n3,mzg,mzs,npat,ifm,theta,pi0,pp,rv,co2p,so ! case (2) ! sfcwater_depth (1,i,j,ipat) = ! sfcwater_mass (1,i,j,ipat) = - ! sfcwater_energy(1,i,j,ipat) = cice * min(t3ple,can_temp) + ! sfcwater_energy(1,i,j,ipat) = tl2uint(min(t3ple,can_temp),0.0) ! case (17,20) ! sfcwater_depth (1,i,j,ipat) = ! sfcwater_mass (1,i,j,ipat) = - ! sfcwater_energy(1,i,j,ipat) = cliq * (max(t3ple,can_temp) -tsupercool) + ! sfcwater_energy(1,i,j,ipat) = tl2uint(max(t3ple,can_temp),1.0) ! end select ! !--------------------------------------------------------------------------! @@ -635,7 +644,8 @@ subroutine sfcinit_nofile_user(n1,n2,n3,mzg,mzs,npat,ifm,theta,pi0,pp,rv,co2p,so ! if (snow_mass(i,j) > 0.) then ! sfcwater_energy(1,i,j,ipat) = ( sfcwater_energy(1,i,j,ipat) & ! * sfcwater_mass (1,i,j,ipat) & - ! + min(t3ple,can_temp)*cice*snow_mass(i,j))& + ! + snow_mass(i,j) & + ! * tl2uint(min(t3ple,can_temp),0.0) ) & ! / (sfcwater_mass(1,i,j,ipat)+snow_mass(i,j)) ! sfcwater_mass (1,i,j,ipat) = sfcwater_mass (1,i,j,ipat)+snow_mass(i,j) ! !-----------------------------------------------------------------------! diff --git a/BRAMS/src/teb_spm/ozone.f90 b/BRAMS/src/teb_spm/ozone.f90 index 08d094ae7..1939469d5 100644 --- a/BRAMS/src/teb_spm/ozone.f90 +++ b/BRAMS/src/teb_spm/ozone.f90 @@ -39,7 +39,7 @@ subroutine ozone(mzp,mxp,myp,ia,iz,ja,jz,ng,deltat) basic_g(ng)%pi0 ,basic_g(ng)%pp, & basic_g(ng)%rv ,radiate_g(ng)%rshort, & radiate_g(ng)%cosz ,grid_g(ng)%rtgt, & - grid_g(ng)%topma ,deltat,cpi,cpor,p00,zt, & + grid_g(ng)%topma ,deltat,cpdryi,cpor,p00,zt, & gaspart_g(ng)%pnot ,gaspart_g(ng)%pno2t, & gaspart_g(ng)%pcot ,gaspart_g(ng)%pvoct, & gaspart_g(ng)%po3t ,gaspart_g(ng)%pso2t, & @@ -63,7 +63,7 @@ subroutine chemistry( m1, m2, m3, ia, iz, ja, jz, & HOi , RO2i , & theta, dn0 , pi0 , pp , & rv , rshort , cosz , rtgt , & - topt, dtlt , cpi, cpor , & + topt, dtlt , cpdryi, cpor , & p00, zt, & not , no2t , cot , & vocst , o3t , so2t, so4t,rchot ,& @@ -100,7 +100,7 @@ subroutine chemistry( m1, m2, m3, ia, iz, ja, jz, & ! model's "constants" used - real :: cpi,cpor,p00,avo,temp + real :: cpdryi,cpor,p00,avo,temp !velocities coefficients @@ -135,11 +135,11 @@ subroutine chemistry( m1, m2, m3, ia, iz, ja, jz, & !calculating absolute temperature using Exner function and Theta - tempk(ik,i,j)=theta(ik,i,j)*pi0(ik,i,j)*cpi + tempk(ik,i,j)=theta(ik,i,j)*pi0(ik,i,j)*cpdryi !calculating pressure - ppi(ik,i,j)=((pp(ik,i,j)+pi0(ik,i,j))*cpi)**cpor*p00 + ppi(ik,i,j)=((pp(ik,i,j)+pi0(ik,i,j))*cpdryi)**cpor*p00 !calculationg the height of each grid point above sea level diff --git a/BRAMS/src/turb/diffuse.f90 b/BRAMS/src/turb/diffuse.f90 index 7dd84cc98..37281854c 100644 --- a/BRAMS/src/turb/diffuse.f90 +++ b/BRAMS/src/turb/diffuse.f90 @@ -104,7 +104,8 @@ subroutine diffuse_brams31() ! - vt3dp -> water vapour mixing ratio; ! ! - vt3dq -> total water substance mixing ratio. ! !---------------------------------------------------------------------------------------! - call azero2(mxyzp,scratch%vt3dp,scratch%vt3dq) + call azero(mxyzp,scratch%vt3dp) + call azero(mxyzp,scratch%vt3dq) if (vapour_on) then call atob(mxyzp,basic_g(ngrid)%rv,scratch%vt3dp) call atob(mxyzp,basic_g(ngrid)%rtp,scratch%vt3dq) diff --git a/BRAMS/src/turb/mem_opt_scratch.f90 b/BRAMS/src/turb/mem_opt_scratch.f90 index ec90c4e21..c203a5cb2 100644 --- a/BRAMS/src/turb/mem_opt_scratch.f90 +++ b/BRAMS/src/turb/mem_opt_scratch.f90 @@ -107,18 +107,18 @@ subroutine nullify_opt_scratch() ! Deallocate all scratch arrays - if (associated(opt%ind1_x_a )) nullify (opt%ind1_x_a ) - if (associated(opt%ind1_x_b )) nullify (opt%ind1_x_b ) - if (associated(opt%ind2_x_a )) nullify (opt%ind2_x_a ) - if (associated(opt%ind2_x_b )) nullify (opt%ind2_x_b ) - if (associated(opt%weight_x_a)) nullify (opt%weight_x_a) - if (associated(opt%weight_x_b)) nullify (opt%weight_x_b) - if (associated(opt%ind1_y_a )) nullify (opt%ind1_y_a ) - if (associated(opt%ind1_y_b )) nullify (opt%ind1_y_b ) - if (associated(opt%ind2_y_a )) nullify (opt%ind2_y_a ) - if (associated(opt%ind2_y_b )) nullify (opt%ind2_y_b ) - if (associated(opt%weight_y_a)) nullify (opt%weight_y_a) - if (associated(opt%weight_y_b)) nullify (opt%weight_y_b) + nullify (opt%ind1_x_a ) + nullify (opt%ind1_x_b ) + nullify (opt%ind2_x_a ) + nullify (opt%ind2_x_b ) + nullify (opt%weight_x_a) + nullify (opt%weight_x_b) + nullify (opt%ind1_y_a ) + nullify (opt%ind1_y_b ) + nullify (opt%ind2_y_a ) + nullify (opt%ind2_y_b ) + nullify (opt%weight_y_a) + nullify (opt%weight_y_b) return diff --git a/BRAMS/src/turb/mem_turb.f90 b/BRAMS/src/turb/mem_turb.f90 index 8190a990a..1e106f0f5 100644 --- a/BRAMS/src/turb/mem_turb.f90 +++ b/BRAMS/src/turb/mem_turb.f90 @@ -147,24 +147,24 @@ subroutine nullify_turb(turb) type (turb_vars), intent(inout) :: turb !------------------------------------------------------------------------------------! - if (associated(turb%tkep )) nullify (turb%tkep ) - if (associated(turb%epsp )) nullify (turb%epsp ) - if (associated(turb%hkm )) nullify (turb%hkm ) - if (associated(turb%vkm )) nullify (turb%vkm ) - if (associated(turb%vkh )) nullify (turb%vkh ) - if (associated(turb%cdrag )) nullify (turb%cdrag ) - if (associated(turb%sflux_r )) nullify (turb%sflux_r ) - if (associated(turb%sflux_u )) nullify (turb%sflux_u ) - if (associated(turb%sflux_v )) nullify (turb%sflux_v ) - if (associated(turb%sflux_w )) nullify (turb%sflux_w ) - if (associated(turb%sflux_t )) nullify (turb%sflux_t ) - if (associated(turb%sflux_c )) nullify (turb%sflux_c ) - if (associated(turb%akscal )) nullify (turb%akscal ) - if (associated(turb%ltscale )) nullify (turb%ltscale ) - if (associated(turb%sigw )) nullify (turb%sigw ) - if (associated(turb%pblhgt )) nullify (turb%pblhgt ) - if (associated(turb%lmo )) nullify (turb%lmo ) - if (associated(turb%kpbl )) nullify (turb%kpbl ) + nullify (turb%tkep ) + nullify (turb%epsp ) + nullify (turb%hkm ) + nullify (turb%vkm ) + nullify (turb%vkh ) + nullify (turb%cdrag ) + nullify (turb%sflux_r ) + nullify (turb%sflux_u ) + nullify (turb%sflux_v ) + nullify (turb%sflux_w ) + nullify (turb%sflux_t ) + nullify (turb%sflux_c ) + nullify (turb%akscal ) + nullify (turb%ltscale ) + nullify (turb%sigw ) + nullify (turb%pblhgt ) + nullify (turb%lmo ) + nullify (turb%kpbl ) return end subroutine nullify_turb diff --git a/BRAMS/src/turb/mem_turb_scalar.f90 b/BRAMS/src/turb/mem_turb_scalar.f90 index 8720c50a8..49b335b0a 100644 --- a/BRAMS/src/turb/mem_turb_scalar.f90 +++ b/BRAMS/src/turb/mem_turb_scalar.f90 @@ -52,7 +52,7 @@ subroutine nullify_turb_s(turb_s_local) ! Deallocate all scratch arrays - if (associated(turb_s_local%hksc )) nullify (turb_s_local%hksc ) + nullify (turb_s_local%hksc ) return end subroutine nullify_turb_s diff --git a/BRAMS/src/turb/tkenn.f90 b/BRAMS/src/turb/tkenn.f90 index 0e96ffc1d..fdff04e5d 100644 --- a/BRAMS/src/turb/tkenn.f90 +++ b/BRAMS/src/turb/tkenn.f90 @@ -98,7 +98,7 @@ subroutine nakanishi(m1,m2,m3,m4,ia,iz,ja,jz,jd,tkep,tket,vt3dd,vt3de,vt3dh,vt3d , qq => vctr38 ! ! intent(out) use rconstants, only : abslmomin & ! intent(in) , abswltlmin & ! intent(in) - , cp & ! intent(in) + , cpdry & ! intent(in) , grav & ! intent(in) , ltscalemax & ! intent(in) , sigwmin & ! intent(in) @@ -353,18 +353,18 @@ subroutine nakanishi(m1,m2,m3,m4,ia,iz,ja,jz,jd,tkep,tket,vt3dd,vt3de,vt3dh,vt3d ! -> Or, if the PBL is convective, then the PBL is defined as the level ! ! where the first minimum of w'theta' ! !------------------------------------------------------------------------------! - kpbl(i,j) = k2w - pblhgt(i,j)=zagl(k2w) - aux= wltl0 * grav / (cp * thetav0(k2w)) + kpbl(i,j) = k2w + pblhgt(i,j) = zagl(k2w) + aux = wltl0 * grav / (cpdry * thetav0(k2w)) convmixlay: do k=k2w+1,m1-1 - kpbl(i,j) = k - pblhgt(i,j)=0.5*(zagl(k)+zagl(k-1)) - wstarw=cbrt(aux * pblhgt(i,j) ) - thetavp(k)=thetav0(k2w)+8.5*wltl0/(wstarw*cp) - ri = grav * (thetav0(k)-thetavp(k)) * (zagl(k)-zagl(k2w)) & - / ( thetavp(k) * ((uspd(k)-uspd(k2w)) * (uspd(k)-uspd(k2w)) & - + (vspd(k)-vspd(k2w)) * (vspd(k)-vspd(k2w)) & - + 100.*ustarw*ustarw) ) + kpbl(i,j) = k + pblhgt(i,j) = 0.5*(zagl(k) + zagl(k-1)) + wstarw = cbrt(aux * pblhgt(i,j) ) + thetavp(k) = thetav0(k2w) + 8.5 * wltl0 / (wstarw*cpdry) + ri = grav * (thetav0(k)-thetavp(k)) * (zagl(k)-zagl(k2w)) & + / ( thetavp(k) * ((uspd(k)-uspd(k2w)) * (uspd(k)-uspd(k2w)) & + + (vspd(k)-vspd(k2w)) * (vspd(k)-vspd(k2w)) & + + 100. * ustarw * ustarw) ) if (ri >= 0.25) exit convmixlay end do convmixlay end if diff --git a/BRAMS/src/turb/turb_derivs.f90 b/BRAMS/src/turb/turb_derivs.f90 index 612d0ae1f..d828c41ba 100644 --- a/BRAMS/src/turb/turb_derivs.f90 +++ b/BRAMS/src/turb/turb_derivs.f90 @@ -149,77 +149,84 @@ end subroutine strain ! virtual temperature profile. It will consider the effect of condensed phase. ! !------------------------------------------------------------------------------------------! subroutine bruvais(ibruvais,m1,m2,m3,ia,iz,ja,jz,pi0,pp,theta,rtp,rv,rtgt,flpw,en2) - use mem_scratch, only : & ! - vctr11 & ! intent(out) - Potential temperature - ,vctr12 & ! intent(out) - Virtual potential temperature - ,vctr1 & ! intent(out) - Height above ground - ,vctr2 & ! intent(out) - coefficient #1 (either cl1 or ci1) - ,vctr3 & ! intent(out) - coefficient #2 (either cl2 or ci2) - ,vctr4 & ! intent(out) - coefficient #3 (either cl3 or ci3) - ,vctr5 & ! intent(out) - Delta-z between k and k+1 - ,vctr6 & ! intent(out) - Delta-z between k-1 and k - ,vctr10 & ! intent(out) - Ratio between z(k)-z(k-½) and z(k+½)-z(k-½) - ,vctr19 & ! intent(out) - g / Height above ground - ,vctr25 & ! intent(out) - d(theta_v)/dz at k+½ - ,vctr26 & ! intent(out) - d(theta_v)/dz at k-½ - ,vctr27 & ! intent(out) - Full Exner function [J/kg/K] - ,vctr28 & ! intent(out) - Pressure [ Pa] - ,vctr29 & ! intent(out) - Temperature [ K] - ,vctr30 & ! intent(out) - Saturation mixing ratio [ kg/kg] - ,vctr31 ! ! intent(out) - Condensed mixing ratio [ kg/kg] - - use mem_grid, only : & - zt & ! intent(in) - ,zm & ! intent(in) - ,nzp & ! intent(in) - ,nz & ! intent(in) - ,nzpmax ! ! intent(in) - - use rconstants, only : & - grav & ! intent(in) - ,t00 & ! intent(in) - ,p00 & ! intent(in) - ,alvl & ! intent(in) - ,alvi & ! intent(in) - ,rdry & ! intent(in) - ,cp & ! intent(in) - ,cpi & ! intent(in) - ,cpor & ! intent(in) - ,ep ! ! intent(in) - - use therm_lib, only : & - virtt & ! function - ,rslf & ! function - ,rsif & ! function - ,vapour_on & ! intent(in) - ,cloud_on & ! intent(in) - ,bulk_on ! ! intent(in) + use mem_scratch, only : vctr11 & ! intent(out) - Potential temperature + , vctr12 & ! intent(out) - Virtual potential temperature + , vctr1 & ! intent(out) - Height above ground + , vctr2 & ! intent(out) - coeff. #1 (either cl1 or ci1) + , vctr3 & ! intent(out) - coeff. #2 (either cl2 or ci2) + , vctr4 & ! intent(out) - coeff. #3 (either cl3 or ci3) + , vctr5 & ! intent(out) - Delta-z between k and k+1 + , vctr6 & ! intent(out) - Delta-z between k-1 and k + , vctr10 & ! intent(out) - [z(k)-z(k-½)]/[z(k+½)-z(k-½)] + , vctr19 & ! intent(out) - g / Height above ground + , vctr25 & ! intent(out) - d(theta_v)/dz at k+½ + , vctr26 & ! intent(out) - d(theta_v)/dz at k-½ + , vctr27 & ! intent(out) - Full Exner function [J/kg/K] + , vctr28 & ! intent(out) - Pressure [ Pa] + , vctr29 & ! intent(out) - Temperature [ K] + , vctr30 & ! intent(out) - Saturation mixing ratio [ kg/kg] + , vctr31 ! ! intent(out) - Condensed mixing ratio [ kg/kg] + + use mem_grid , only : zt & ! intent(in) + , zm & ! intent(in) + , nzp & ! intent(in) + , nz & ! intent(in) + , nzpmax ! ! intent(in) + + use rconstants , only : grav & ! intent(in) + , t00 & ! intent(in) + , alvl3 & ! intent(in) + , alvi3 & ! intent(in) + , rdry & ! intent(in) + , cpdry & ! intent(in) + , cpdryi & ! intent(in) + , ep ! ! intent(in) + + use therm_lib , only : virtt & ! function + , rslf & ! function + , rsif & ! function + , exner2press & ! function + , extheta2temp & ! function + , vapour_on & ! intent(in) + , cloud_on & ! intent(in) + , bulk_on ! ! intent(in) implicit none !----- Arguments -----------------------------------------------------------------------! - integer , intent(in ) :: ibruvais ! Method to compute N² [ ---] - integer , intent(in ) :: m1,m2,m3 ! Z,X,Y dimensions [ ---] - integer , intent(in ) :: ia,iz ! West-East node bound. [ ---] - integer , intent(in ) :: ja,jz ! South-North node bound. [ ---] - real, dimension(m1,m2,m3), intent(in ) :: pi0 ! Ref. Exner function [J/kg/K] - real, dimension(m1,m2,m3), intent(in ) :: pp ! Perturbation on Exner [J/kg/K] - real, dimension(m1,m2,m3), intent(in ) :: theta ! Potential temperature [ K] - real, dimension(m1,m2,m3), intent(in ) :: rtp ! Total mixing ratio [ kg/kg] - real, dimension(m1,m2,m3), intent(in ) :: rv ! Vapour mixing ratio [ kg/kg] - real, dimension( m2,m3), intent(in ) :: rtgt ! Sigma-z correction [ m/m] - real, dimension( m2,m3), intent(in ) :: flpw ! Lowest point in W grid [ ---] - real, dimension(m1,m2,m3), intent(inout) :: en2 ! (Brunt-Väisälä freq.)² [ Hz²] + integer , intent(in ) :: ibruvais ! Method to compute N² [ ---] + integer , intent(in ) :: m1 ! Z dimensions [ ---] + integer , intent(in ) :: m2 ! X dimensions [ ---] + integer , intent(in ) :: m3 ! Y dimensions [ ---] + integer , intent(in ) :: ia ! West end index [ ---] + integer , intent(in ) :: iz ! East end index [ ---] + integer , intent(in ) :: ja ! South end index [ ---] + integer , intent(in ) :: jz ! North end index [ ---] + real, dimension(m1,m2,m3), intent(in ) :: pi0 ! Ref. Exner function [ J/kg/K] + real, dimension(m1,m2,m3), intent(in ) :: pp ! Perturbation on Exner [ J/kg/K] + real, dimension(m1,m2,m3), intent(in ) :: theta ! Potential temperature [ K] + real, dimension(m1,m2,m3), intent(in ) :: rtp ! Total mixing ratio [ kg/kg] + real, dimension(m1,m2,m3), intent(in ) :: rv ! Vapour mixing ratio [ kg/kg] + real, dimension( m2,m3), intent(in ) :: rtgt ! Sigma-z correction [ m/m] + real, dimension( m2,m3), intent(in ) :: flpw ! Lowest point in W grid [ ---] + real, dimension(m1,m2,m3), intent(inout) :: en2 ! (Brunt-Väisälä freq.)² [ Hz²] !----- Local variables -----------------------------------------------------------------! - integer :: i,j,k,ki,k2,k1 - real :: temp,rvlsi,rvii + integer :: i + integer :: j + integer :: k + integer :: ki + integer :: k2 + integer :: k1 + real :: temp + real :: rvlsi + real :: rvii !----- Local constants, for alternative method to compute N², test only ----------------! - real, parameter :: cl1 = alvl / rdry - real, parameter :: cl2 = ep * alvl ** 2 / (cp * rdry) - real, parameter :: cl3 = alvl / cp - real, parameter :: ci1 = alvi / rdry - real, parameter :: ci2 = ep * alvi ** 2 / (cp * rdry) - real, parameter :: ci3 = alvi / cp + real , parameter :: cl1 = alvl3 / rdry + real , parameter :: cl2 = ep * alvl3 ** 2 / (cpdry * rdry) + real , parameter :: cl3 = alvl3 / cpdry + real , parameter :: ci1 = alvi3 / rdry + real , parameter :: ci2 = ep * alvi3 ** 2 / (cpdry * rdry) + real , parameter :: ci3 = alvi3 / cpdry !---------------------------------------------------------------------------------------! @@ -275,8 +282,8 @@ subroutine bruvais(ibruvais,m1,m2,m3,ia,iz,ja,jz,pi0,pp,theta,rtp,rv,rtgt,flpw,e do k=k1,m1 vctr27(k) = pi0(k,i,j) + pp(k,i,j) - vctr28(k) = p00 * (cpi * vctr27(k)) ** cpor - vctr29(k) = theta(k,i,j) * vctr27(k) * cpi + vctr28(k) = exner2press(vctr27(k)) + vctr29(k) = extheta2temp(vctr27(k),theta(k,i,j)) !---------------------------------------------------------------------------! ! Deciding which coefficient to use. This is inconsistent with most ! diff --git a/BRAMS/src/turb/turb_k.f90 b/BRAMS/src/turb/turb_k.f90 index c97d13d1d..dc59b202f 100644 --- a/BRAMS/src/turb/turb_k.f90 +++ b/BRAMS/src/turb/turb_k.f90 @@ -100,7 +100,8 @@ subroutine diffuse() ! - vt3dp -> water vapour mixing ratio; ! ! - vt3dq -> total water substance mixing ratio. ! !---------------------------------------------------------------------------------------! - call azero2(mxyzp,scratch%vt3dp,scratch%vt3dq) + call azero(mxyzp,scratch%vt3dp) + call azero(mxyzp,scratch%vt3dq) if (vapour_on) then call atob(mxyzp,basic_g(ngrid)%rv,scratch%vt3dp) call atob(mxyzp,basic_g(ngrid)%rtp,scratch%vt3dq) diff --git a/ED/Template/Template/ED2IN b/ED/Template/Template/ED2IN index d987377da..b047d679e 100644 --- a/ED/Template/Template/ED2IN +++ b/ED/Template/Template/ED2IN @@ -583,6 +583,20 @@ $ED_NL !---------------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------------! + ! IBIGLEAF -- Do you want to run ED as a 'big leaf' model? ! + ! 0. No, use the standard size- and age-structure (Moorcroft et al. 2001) ! + ! This is the recommended method for most applications. ! + ! 1. 'big leaf' ED: this will have no horizontal or vertical hetero- ! + ! geneities; 1 patch per PFT and 1 cohort per patch; no vertical ! + ! growth, recruits will 'appear' instantaneously at maximum height. ! + ! ! + ! N.B. if you set IBIGLEAF to 1, you MUST turn off the crown model (CROWN_MOD = 0) ! + !---------------------------------------------------------------------------------------! + NL%IBIGLEAF = mybigleaf + !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! @@ -591,6 +605,8 @@ $ED_NL ! errors. ! ! 1. Fourth-order Runge-Kutta method. ED-2.1 default method ! ! 2. Heun's method (a second-order Runge-Kutta). ! + ! 3. Hybrid Stepping (BDF2 implicit step for the canopy air and ! + ! leaf temp, forward Euler for else, under development). ! !---------------------------------------------------------------------------------------! NL%INTEGRATION_SCHEME = 1 !---------------------------------------------------------------------------------------! @@ -731,8 +747,12 @@ $ED_NL ! to the same polygon, even if they are in different sites. They ! ! can't go outside their original polygon, though. This is the ! ! same as option 1 if there is only one site per polygon. ! + ! 3. Similar to 2, but recruits will only be formed if their phenology ! + ! status would be "leaves fully flushed". This only matters for ! + ! drought deciduous plants. This option is for testing purposes ! + ! only, think 50 times before using it... ! !---------------------------------------------------------------------------------------! - NL%REPRO_SCHEME = 2 + NL%REPRO_SCHEME = myrepro !---------------------------------------------------------------------------------------! @@ -958,24 +978,28 @@ $ED_NL !---------------------------------------------------------------------------------------! ! The following parameters adjust the fire disturbance in the model. ! - ! INCLUDE_FIRE -- Which threshold to use for fires. ! - ! 0. No fires; ! - ! 1. (deprecated) Fire will be triggered with enough biomass and ! - ! integrated ground water depth less than a threshold. Based on ! - ! ED-1, the threshold assumes that the soil is 1 m, so deeper ! - ! soils will need to be much drier to allow fires to happen and ! - ! often will never allow fires. ! - ! 2. Fire will be triggered with enough biomass and the total soil ! - ! water at the top 75 cm falls below a threshold. ! - ! SM_FIRE -- This is used only when INCLUDE_FIRE = 2. The sign here matters. ! - ! >= 0. - Minimum relative soil moisture above dry air of the top 75cm ! - ! that will prevent fires to happen. ! - ! < 0. - Minimum mean soil moisture potential in MPa of the top 75 cm ! - ! that will prevent fires to happen. The dry air soil ! - ! potential is defined as -3.1 MPa, so make sure SM_FIRE is ! - ! greater than this value. ! - !---------------------------------------------------------------------------------------! - NL%INCLUDE_FIRE = 2 + ! INCLUDE_FIRE -- Which threshold to use for fires. ! + ! 0. No fires; ! + ! 1. (deprecated) Fire will be triggered with enough biomass and ! + ! integrated ground water depth less than a threshold. Based on ! + ! ED-1, the threshold assumes that the soil is 1 m, so deeper ! + ! soils will need to be much drier to allow fires to happen and ! + ! often will never allow fires. ! + ! 2. Fire will be triggered with enough biomass and the total soil ! + ! water at the top 75 cm falls below a threshold. ! + ! FIRE_PARAMETER -- If fire happens, this will control the intensity of the disturbance ! + ! given the amount of fuel (currently the total above-ground ! + ! biomass). ! + ! SM_FIRE -- This is used only when INCLUDE_FIRE = 2. The sign here matters. ! + ! >= 0. - Minimum relative soil moisture above dry air of the top 1m ! + ! that will prevent fires to happen. ! + ! < 0. - Minimum mean soil moisture potential in MPa of the top 1m ! + ! that will prevent fires to happen. The dry air soil ! + ! potential is defined as -3.1 MPa, so make sure SM_FIRE is ! + ! greater than this value. ! + !---------------------------------------------------------------------------------------! + NL%INCLUDE_FIRE = myfire + NL%FIRE_PARAMETER = myfuel NL%SM_FIRE = mysmfire !---------------------------------------------------------------------------------------! @@ -1085,7 +1109,7 @@ $ED_NL ! 2. Soil conductivity decreases with depth even for constant soil moisture ! ! , otherwise it is the same as 1. ! !---------------------------------------------------------------------------------------! - NL%IPERCOL = 1 + NL%IPERCOL = mypercol !---------------------------------------------------------------------------------------! @@ -1133,30 +1157,33 @@ $ED_NL !---------------------------------------------------------------------------------------! ! The following variables control the size of sub-polygon structures in ED-2. ! - ! MAXSITE -- This is the strict maximum number of sites that each polygon can ! - ! contain. Currently this is used only when the user wants to run the ! - ! same polygon with multiple soil types. If there aren't that many ! - ! different soil types with a minimum area (check MIN_SITE_AREA ! - ! below), then the model will allocate just the amount needed. ! - ! MAXPATCH -- If number of patches in a given site exceeds MAXPATCH, force patch ! - ! fusion. If MAXPATCH is 0, then fusion will never happen. If ! - ! MAXPATCH is negative, then the absolute value is used only during ! - ! the initialization, and fusion will never happen again. Notice that ! - ! if the patches are too different, then the actual number of patches ! - ! in a site may exceed MAXPATCH. ! - ! MAXCOHORT -- If number of cohorts in a given patch exceeds MAXCOHORT, force ! - ! cohort fusion. If MAXCOHORT is 0, then fusion will never happen. ! - ! If MAXCOHORT is negative, then the absolute value is used only ! - ! during the initialization, and fusion will never happen again. ! - ! Notice that if the cohorts are too different, then the actual number ! - ! of cohorts in a patch may exceed MAXCOHORT. ! - ! MIN_SITE_AREA -- This is the minimum fraction area of a given soil type that allows a ! - ! site to be created (ignored if IED_INIT_MODE is set to 3). ! - !---------------------------------------------------------------------------------------! - NL%MAXSITE = 1 - NL%MAXPATCH = 20 - NL%MAXCOHORT = 80 - NL%MIN_SITE_AREA = 0.005 + ! MAXSITE -- This is the strict maximum number of sites that each polygon can ! + ! contain. Currently this is used only when the user wants to run ! + ! the same polygon with multiple soil types. If there aren't that ! + ! many different soil types with a minimum area (check MIN_SITE_AREA ! + ! below), then the model will allocate just the amount needed. ! + ! MAXPATCH -- If number of patches in a given site exceeds MAXPATCH, force patch ! + ! fusion. If MAXPATCH is 0, then fusion will never happen. If ! + ! MAXPATCH is negative, then the absolute value is used only during ! + ! the initialization, and fusion will never happen again. Notice ! + ! that if the patches are too different, then the actual number of ! + ! patches in a site may exceed MAXPATCH. ! + ! MAXCOHORT -- If number of cohorts in a given patch exceeds MAXCOHORT, force ! + ! cohort fusion. If MAXCOHORT is 0, then fusion will never happen. ! + ! If MAXCOHORT is negative, then the absolute value is used only ! + ! during the initialization, and fusion will never happen again. ! + ! Notice that if the cohorts are too different, then the actual ! + ! number of cohorts in a patch may exceed MAXCOHORT. ! + ! MIN_SITE_AREA -- This is the minimum fraction area of a given soil type that allows ! + ! a site to be created (ignored if IED_INIT_MODE is set to 3). ! + ! MIN_PATCH_AREA -- This is the minimum fraction area of a given soil type that allows ! + ! a site to be created (ignored if IED_INIT_MODE is set to 3). ! + !---------------------------------------------------------------------------------------! + NL%MAXSITE = 1 + NL%MAXPATCH = 20 + NL%MAXCOHORT = 80 + NL%MIN_SITE_AREA = 0.005 + NL%MIN_PATCH_AREA = 0.005 !---------------------------------------------------------------------------------------! @@ -1196,7 +1223,7 @@ $ED_NL ! -folding lifetime" of the TSW in seconds due to runoff. If you don't ! ! want runoff to happen, set this to 0. ! !---------------------------------------------------------------------------------------! - NL%RUNOFF_TIME = 1800. + NL%RUNOFF_TIME = myrunoff !---------------------------------------------------------------------------------------! @@ -1327,6 +1354,49 @@ $ED_NL + !---------------------------------------------------------------------------------------! + ! The following variables are used to control the detailed output for debugging ! + ! purposes. ! + ! ! + ! IDETAILED -- This flag controls the possible detailed outputs, mostly used for ! + ! debugging purposes. Notice that this doesn't replace the normal debug- ! + ! ger options, the idea is to provide detailed output to check bad ! + ! assumptions. The options are additive, and the indices below represent ! + ! the different types of output: ! + ! ! + ! 1 -- Detailed budget (every DTLSM) ! + ! 2 -- Detailed photosynthesis (every DTLSM) ! + ! 4 -- Detailed output from the integrator (every HDID) ! + ! 8 -- Thermodynamic bounds for sanity check (every DTLSM) ! + ! 16 -- Daily error stats (which variable caused the time step to shrink) ! + ! 32 -- Allometry parameters, and minimum and maximum sizes ! + ! (two files, only at the beginning) ! + ! ! + ! In case you don't want any detailed output (likely for most runs), set ! + ! IDETAILED to zero. In case you want to generate multiple outputs, add ! + ! the number of the sought options: for example, if you want detailed ! + ! photosynthesis and detailed output from the integrator, set IDETAILED ! + ! to 6 (2 + 4). Any combination of the above outputs is acceptable, al- ! + ! though all but the last produce a sheer amount of txt files, in which ! + ! case you may want to look at variable PATCH_KEEP. It is also a good ! + ! idea to set IVEGT_DYNAMICS to 0 when using the first five outputs. ! + ! ! + ! ! + ! PATCH_KEEP -- This option will eliminate all patches except one from the initial- ! + ! isation. This is only used when one of the first five types of ! + ! detailed output is active, otherwise it will be ignored. Options are: ! + ! -2. Keep only the patch with the lowest potential LAI ! + ! -1. Keep only the patch with the highest potential LAI ! + ! 0. Keep all patches. ! + ! > 0. Keep the patch with the provided index. In case the index is ! + ! not valid, the model will crash. ! + !---------------------------------------------------------------------------------------! + NL%IDETAILED = 0 + NL%PATCH_KEEP = 0 + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! ! IOPTINPT -- Optimization configuration. (Currently not used) ! !---------------------------------------------------------------------------------------! diff --git a/ED/Template/Template/callserial.sh b/ED/Template/Template/callserial.sh index 96ff11710..134540bac 100755 --- a/ED/Template/Template/callserial.sh +++ b/ED/Template/Template/callserial.sh @@ -11,7 +11,7 @@ currloc=`pwd` # Current location mddir='met_driver' datasrc='mypackdata' -datadest='/scratch/mlongo' +datadest='/scratch/ed2_data' datasize=39000000 #------------------------------------------------------------------------------------------# diff --git a/ED/Template/Template/ed_2.1-opt b/ED/Template/Template/ed_2.1-opt new file mode 120000 index 000000000..114b26ed3 --- /dev/null +++ b/ED/Template/Template/ed_2.1-opt @@ -0,0 +1 @@ +../executable/ed_2.1-opt \ No newline at end of file diff --git a/ED/Template/Template/patchprops.r b/ED/Template/Template/patchprops.r index 385d7f176..0119f98e1 100644 --- a/ED/Template/Template/patchprops.r +++ b/ED/Template/Template/patchprops.r @@ -1,6 +1,7 @@ #----- Here is the user-defined variable section. -----------------------------------------# here = "thispath" # Current directory. -srcdir = "/n/Moorcroft_Lab/Users/mlongo/util/Rsc" # Property directory. +there = "thatpath" # Directory where analyses/history are +srcdir = "/n/moorcroft_data/mlongo/util/Rsc" # Property directory. when = c("thismontha/thisdatea/thisyeara","thishoura:thisminua:00") # Time to grab the history outroot = "thisoutroot" myplaces = c("thispoly") # Places to find patch properties @@ -171,8 +172,8 @@ for (ipy in 1:nplaces){ place = myplaces[ipy] #----- Retrieve default information about this place and set up some variables. --------# - thispoi = locations(where=place,here=here) - inpref = paste(here,place,"histo",place,sep="/") + thispoi = locations(where=place,here=there) + inpref = paste(there,place,"histo",place,sep="/") outpref = thispoi$pathout lieu = thispoi$lieu suffix = thispoi$iata diff --git a/ED/Template/Template/plot_budget.r b/ED/Template/Template/plot_budget.r new file mode 100644 index 000000000..cdc07fd02 --- /dev/null +++ b/ED/Template/Template/plot_budget.r @@ -0,0 +1,426 @@ +#----- Here is the user-defined variable section. -----------------------------------------# +here = "thispath" # Current directory. +srcdir = "/n/moorcroft_data/mlongo/util/Rsc" # Source directory. +outroot = "thisoutroot" # Source directory. +myplaces = c("thispoly") +#------------------------------------------------------------------------------------------# +# Initial and final times, they must be character vectors of size 2, the first one # +# with m/d/y, and the second one with h:m:s". # +#------------------------------------------------------------------------------------------# +whena = c("thismontha/thisdatea/thisyeara","thishoura:thisminua:00") +whenz = c("thismonthz/thisdatez/thisyearz","thishourz:thisminuz:00") +ptype = "l" # Type of plot +ptyped = "p" # Type of plot +ptypeb = "o" # Type of plot + +outform = "png" # Formats for output file. Supported formats are: + # - "X11" - for printing on screen + # - "eps" - for postscript printing + # - "png" - for PNG printing + +cex.main = 0.8 # Scale coefficient for the title + +byeold = TRUE # Remove old files of the given format? + +depth = 96 # PNG resolution, in pixels per inch +paper = "letter" # Paper size, to define the plot shape +ptsz = 14 # Font size. +lwidth = 2.5 # Line width +plotgrid = TRUE # Should I plot the grid in the background? + +legwhere = "topleft" # Where should I place the legend? +inset = 0.05 # inset distance between legend and edge of plot region. +legbg = "white" # Legend background colour. + +scalleg = 0.32 # Increase in y scale to fit the legend. +ncolshov = 200 # Target number of colours for Hovmoller diagrams. +hovgrid = TRUE # Should I include a grid on the Hovmoller plots? + + +#------------------------------------------------------------------------------------------# +#------------------------------------------------------------------------------------------# +# List of possible plots. In case you don't want some of them, simply switch plt to F. # +#------------------------------------------------------------------------------------------# +#----- Time series plots. -----------------------------------------------------------------# +budget = list() +budget[[ 1]] = list( vnam = c("co2.dstorage","co2.nep","co2.dens.eff" + ,"co2.loss2atm","co2.residual") + , desc = c("Delta (Storage)","NEP","Density Effect" + ,"Eddy flux loss","Residual") + , colour = c("forestgreen","chartreuse","purple4" + ,"deepskyblue","black") + , lwd = c(2.0,2.0,2.0,2.0,2.0) + , range = c(FALSE,TRUE,TRUE,TRUE,TRUE) + , type = ptype + , plog = "" + , prefix = "carbflux" + , theme = "Carbon dioxide budget" + , unit = "umol/m2/s" + , legpos = "topleft" + , plt = TRUE) +budget[[ 2]] = list( vnam = c("ene.dstorage","ene.precip","ene.netrad" + ,"ene.dens.eff","ene.prss.eff","ene.loss2atm" + ,"ene.drainage","ene.runoff","ene.residual") + , desc = c("Delta (Storage)","Rainfall","Net Radiation" + ,"Density effect","Pressure effect","Eddy flux loss" + ,"Drainage","Runoff","Residual") + , colour = c("red3","royalblue","darkorange" + ,"purple4","chartreuse","deepskyblue","sienna" + ,"forestgreen","black") + , lwd = c(2.0,2.0,2.0,2.0,2.0,2.0,2.0,2.0,2.0) + , range = c(FALSE,FALSE,TRUE,TRUE,TRUE,TRUE,FALSE,FALSE,TRUE) + , type = ptype + , plog = "" + , prefix = "eneflux" + , theme = "Enthalpy budget" + , unit = "W/m2" + , legpos = "topleft" + , plt = TRUE) +budget[[ 3]] = list( vnam = c("h2o.dstorage","h2o.precip","h2o.dens.eff" + ,"h2o.loss2atm","h2o.drainage","h2o.runoff","h2o.residual") + , desc = c("Delta (Storage)","Rainfall","Density effect" + ,"Eddy flux loss","Drainage","Runoff","Residual") + , colour = c("red3","royalblue","purple4" + ,"deepskyblue","sienna","forestgreen","black") + , lwd = c(2.0,2.0,2.0,2.0,2.0,2.0,2.0) + , range = c(FALSE,FALSE,TRUE,TRUE,FALSE,FALSE,TRUE) + , type = ptype + , plog = "" + , prefix = "h2oflux" + , theme = "Water budget" + , unit = "kg/m2/day" + , legpos = "topleft" + , plt = TRUE) +budget[[ 4]] = list( vnam = c("co2.cumres") + , desc = c("Residual") + , colour = c("limegreen") + , lwd = c(2.0) + , range = c(TRUE) + , type = ptype + , plog = "" + , prefix = "cumco2" + , theme = "CO2: cumulative residual (absolute)" + , unit = "umol/m2" + , legpos = "topleft" + , plt = TRUE) +budget[[ 5]] = list( vnam = c("ene.cumres") + , desc = c("Residual") + , colour = c("red3") + , lwd = c(2.0) + , range = c(TRUE) + , type = ptype + , plog = "" + , prefix = "cumene" + , theme = "Enthalpy: cumulative residual (absolute)" + , unit = "J/m2" + , legpos = "topleft" + , plt = TRUE) +budget[[ 6]] = list( vnam = c("h2o.cumres") + , desc = c("Residual") + , colour = c("steelblue") + , lwd = c(2.0) + , range = c(TRUE) + , type = ptype + , plog = "" + , prefix = "cumh2o" + , theme = "Water: cumulative residual (absolute)" + , unit = "kg/m2" + , legpos = "topleft" + , plt = TRUE) +budget[[ 7]] = list( vnam = c("co2.relres") + , desc = c("Residual") + , colour = c("limegreen") + , lwd = c(2.0) + , range = c(TRUE) + , type = ptype + , plog = "" + , prefix = "relco2" + , theme = "CO2: cumulative residual (relative)" + , unit = "---" + , legpos = "topleft" + , plt = TRUE) +budget[[ 8]] = list( vnam = c("ene.relres") + , desc = c("Residual") + , colour = c("red3") + , lwd = c(2.0) + , range = c(TRUE) + , type = ptype + , plog = "" + , prefix = "relene" + , theme = "Enthalpy: cumulative residual (relative)" + , unit = "---" + , legpos = "topleft" + , plt = TRUE) +budget[[ 9]] = list( vnam = c("h2o.relres") + , desc = c("Residual") + , colour = c("steelblue") + , lwd = c(2.0) + , range = c(TRUE) + , type = ptype + , plog = "" + , prefix = "relh2o" + , theme = "Water: cumulative residual (relative)" + , unit = "---" + , legpos = "topleft" + , plt = TRUE) +#------------------------------------------------------------------------------------------# + + + +#----- Loading some packages. -------------------------------------------------------------# +library(hdf5) +library(chron) +library(scatterplot3d) +library(lattice) +library(maps) +library(mapdata) +library(akima) +#------------------------------------------------------------------------------------------# + + + +#----- In case there is some graphic still opened. ----------------------------------------# +graphics.off() +#------------------------------------------------------------------------------------------# + + + +#----- Setting how many formats we must output. -------------------------------------------# +outform = tolower(outform) +nout = length(outform) +#------------------------------------------------------------------------------------------# + + + +#----- Avoiding unecessary and extremely annoying beeps. ----------------------------------# +options(locatorBell=FALSE) +#------------------------------------------------------------------------------------------# + + + +#----- Loading some files with functions. -------------------------------------------------# +source(paste(srcdir,"atlas.r" ,sep="/")) +source(paste(srcdir,"globdims.r" ,sep="/")) +source(paste(srcdir,"locations.r" ,sep="/")) +source(paste(srcdir,"muitas.r" ,sep="/")) +source(paste(srcdir,"pretty.log.r" ,sep="/")) +source(paste(srcdir,"pretty.time.r",sep="/")) +source(paste(srcdir,"plotsize.r" ,sep="/")) +source(paste(srcdir,"qapply.r" ,sep="/")) +source(paste(srcdir,"rconstants.r" ,sep="/")) +source(paste(srcdir,"sombreado.r" ,sep="/")) +source(paste(srcdir,"southammap.r" ,sep="/")) +source(paste(srcdir,"thermlib.r" ,sep="/")) +source(paste(srcdir,"timeutils.r" ,sep="/")) +#------------------------------------------------------------------------------------------# + + + +#----- Define plot window size ------------------------------------------------------------# +size = plotsize(proje=FALSE,paper=paper) +#------------------------------------------------------------------------------------------# + + + +#----- Define the initial and final time --------------------------------------------------# +whena = chron(dates=whena[1],times=whena[2]) +whenz = chron(dates=whenz[1],times=whenz[2]) +#------------------------------------------------------------------------------------------# + + + +#----- Time series for the patch ----------------------------------------------------------# +nbudget = length(budget) +#------------------------------------------------------------------------------------------# + + + +#------------------------------------------------------------------------------------------# +# Big place loop starts here... # +#------------------------------------------------------------------------------------------# +for (place in myplaces){ + + #----- Retrieve default information about this place and set up some variables. --------# + thispoi = locations(where=place,here=here) + inpref = paste(here,place,sep="/") + outpref = thispoi$pathout + lieu = thispoi$lieu + suffix = thispoi$iata + #---------------------------------------------------------------------------------------# + + + #----- Print the banner to entretain the user. -----------------------------------------# + print (paste(" + ",thispoi$lieu,"...",sep="")) + #---------------------------------------------------------------------------------------# + + #----- Make the main output directory in case it doesn't exist. ------------------------# + if (! file.exists(outroot)) dir.create(outroot) + outmain = paste(outroot,place,sep="/") + if (! file.exists(outmain)) dir.create(outmain) + outdir = paste(outmain,"budget",sep="/") + if (! file.exists(outdir)) dir.create(outdir) + #---------------------------------------------------------------------------------------# + + + #----- Determine the number of patches. ------------------------------------------------# + filelist = dir(inpref) + mypatches = length(grep("budget_state_patch_",filelist)) + #---------------------------------------------------------------------------------------# + + + + #---------------------------------------------------------------------------------------# + # Patch loop. # + #---------------------------------------------------------------------------------------# + for (ipa in 1:mypatches){ + #----- Find the character version of the patch number. ------------------------------# + cipa = substring(10000+ipa,2,5) + + print (paste(" - Patch # ",ipa,"...",sep="")) + #----- Define the output directory. -------------------------------------------------# + patchdir = paste(outdir,paste("patch_",cipa,sep=""),sep="/") + if (! file.exists(patchdir)) dir.create(patchdir) + + #----- Define the input file name. --------------------------------------------------# + inputfile = paste(inpref,paste("budget_state_patch_",cipa,".txt",sep=""),sep="/") + print(paste(" * Open file:",inputfile)) + + #----- Read the file, just to grab the header. --------------------------------------# + vnames = scan(file=inputfile,what="raw",nlines=1,quiet=TRUE) + nvars = length(vnames) + for (v in 1:nvars){ + aux = tolower(vnames[v]) + saux = strsplit(aux,split="")[[1]] + uscore = which(saux == "_") + saux[uscore] = "." + vnames[v] = paste(saux,collapse="") + }#end for + #------------------------------------------------------------------------------------# + + + #------------------------------------------------------------------------------------# + # Read the input file, this time reading all the data and skipping the first # + # line. # + #------------------------------------------------------------------------------------# + aux = as.numeric(scan(file=inputfile,what="numeric",skip=1 + ,quiet=TRUE)) + cpatch = matrix(aux,ncol=nvars,byrow=TRUE) + dimnames(cpatch) = list(NULL,vnames) + cpatch = data.frame(cpatch) + + #----- Reduce the size of the file to be the period of interest only. ---------------# + print(paste(" * Reduce data to the period of interest...")) + when = chron( chron(dates=paste(cpatch$month,cpatch$day,cpatch$year,sep="/")) + + cpatch$time/day.sec, out.format=c(dates="m/d/y",times="h:m:s")) + sel = when >= whena & when <= whenz + cpatch = cpatch[sel,] + when = when[sel] + + #----- Re-scale or re-define some variables. ----------------------------------------# + print(paste(" * Define the cumulative sum of residuals...")) + cpatch$co2.cumres=cumsum(cpatch$co2.residual) + cpatch$ene.cumres=cumsum(cpatch$ene.residual) + cpatch$h2o.cumres=cumsum(cpatch$h2o.residual / day.sec) + cpatch$co2.relres=cumsum(cpatch$co2.residual) / cpatch$co2.storage + cpatch$ene.relres=cumsum(cpatch$ene.residual) / cpatch$ene.storage + cpatch$h2o.relres=cumsum(cpatch$h2o.residual / day.sec) / cpatch$h2o.storage + + #------------------------------------------------------------------------------------# + # Define a nice grid for time. # + #------------------------------------------------------------------------------------# + whenout = pretty.time(when,n=8) + #------------------------------------------------------------------------------------# + + + + #------------------------------------------------------------------------------------# + # Plot the time series diagrams showing months and years. # + #------------------------------------------------------------------------------------# + print(paste(" * Plot some patch-level figures...")) + for (bb in 1:nbudget){ + + #----- Retrieve variable information from the list. ------------------------------# + budget.now = budget[[bb]] + vnames = budget.now$vnam + description = budget.now$desc + lcolours = budget.now$colour + llwd = budget.now$lwd + lrange = budget.now$range + ltype = budget.now$type + plog = budget.now$plog + prefix = budget.now$prefix + theme = budget.now$theme + unit = budget.now$unit + legpos = budget.now$legpos + plotit = budget.now$plt + + if (plotit){ + + + #----- Define the number of layers. -------------------------------------------# + nlayers = length(vnames) + namerange = vnames[lrange] + ylimit = max(abs(cpatch[,namerange]),na.rm=TRUE) + ylimit = c(-ylimit,ylimit) + if (ylimit[1] == ylimit[2] & ylimit[1] == 0){ + ylimit[1] = -1 + ylimit[2] = 1 + }else if (ylimit[1] == ylimit[2] & ylimit[1] > 0){ + ylimit[2] = (1.0+scalleg) * ylimit[1] + }else if (ylimit[1] == ylimit[2] & ylimit[1] < 0){ + ylimit[2] = (1.0-scalleg) * ylimit[1] + }else{ + ylimit[2] = ylimit[2] + scalleg * (ylimit[2] - ylimit[1]) + }#end if + + #------------------------------------------------------------------------------# + # Check if the directory exists. If not, create it. # + #------------------------------------------------------------------------------# + print (paste(" > ",theme," time series ...",sep="")) + + #----- Loop over formats. -----------------------------------------------------# + for (o in 1:nout){ + fichier = paste(patchdir,"/",prefix,"-patch-",cipa,"-",suffix + ,".",outform[o],sep="") + if(outform[o] == "x11"){ + X11(width=size$width,height=size$height,pointsize=ptsz) + }else if(outform[o] == "png"){ + png(filename=fichier,width=size$width*depth,height=size$height*depth + ,pointsize=ptsz,res=depth) + }else if(outform[o] == "eps"){ + postscript(file=fichier,width=size$width,height=size$height + ,pointsize=ptsz,paper=paper) + }#end if + + letitre = paste(theme," - ",thispoi$lieu,"(Patch ",ipa,")", + " \n"," Time series: ",theme,sep="") + + plot(x=when,y=cpatch[[vnames[1]]],type="n",main=letitre,xlab="Time" + ,ylim=ylimit,ylab=paste("[",unit,"]",sep=""),log=plog,xaxt="n" + ,cex.main=cex.main) + axis(side=1,at=whenout$levels,labels=whenout$labels,padj=whenout$padj) + if (hovgrid){ + abline(h=axTicks(side=2),v=whenout$levels,col="gray66",lty="dotted") + }#end if + for (l in 1:nlayers){ + points(x=when,y=cpatch[[vnames[l]]],col=lcolours[l] + ,lwd=llwd[l],type=ltype,pch=16,cex=0.8) + }#end for + legend(x=legpos,inset=0.01,legend=description,col=lcolours,lwd=llwd + ,ncol=2,cex=0.9) + if (outform[o] == "x11"){ + locator(n=1) + dev.off() + }else{ + dev.off() + }#end if + } #end for outform + }#end if plotit + }#end for nphov + #------------------------------------------------------------------------------------# + + }#end for (ipa in patches) + #---------------------------------------------------------------------------------------# + +}#end for (place in myplaces) +#------------------------------------------------------------------------------------------# diff --git a/ED/Template/Template/plot_daily.r b/ED/Template/Template/plot_daily.r index a72ac512f..e6f6cd4d4 100644 --- a/ED/Template/Template/plot_daily.r +++ b/ED/Template/Template/plot_daily.r @@ -1,6 +1,6 @@ #----- Here is the user-defined variable section. -----------------------------------------# here = "thispath" # Current directory. -srcdir = "/n/Moorcroft_Lab/Users/mlongo/util/Rsc" +srcdir = "/n/moorcroft_data/mlongo/util/Rsc" outroot = "thisoutroot" daybeg = thisdatea monthbeg = thismontha @@ -58,16 +58,16 @@ tsplot04 = list(vnam="mcopft" ,desc="Maintenance costs" ,unit="kgC/m2/ #----- Size (DBH) and age structure of cohort level variables. ----------------------------# npsas = 10 -psas01 = list(vnam="beamextco",desc="Downward direct light" ,unit="--" , plt=T) -psas02 = list(vnam="gppco" ,desc="Gross primary productivity",unit="kgC/plant/yr", plt=T) -psas03 = list(vnam="respco" ,desc="Total plant respiration" ,unit="kgC/plant/yr", plt=T) -psas04 = list(vnam="nppco" ,desc="Net primary productivity" ,unit="kgC/plant/yr", plt=T) -psas05 = list(vnam="mcostco" ,desc="Maintenance costs" ,unit="kgC/plant/yr", plt=T) -psas06 = list(vnam="ncbmortco",desc="Mortality due to Neg. CB" ,unit="1/yr" , plt=T) -psas07 = list(vnam="agbco" ,desc="Above-ground biomass" ,unit="kgC/plant" , plt=T) -psas08 = list(vnam="fsoco" ,desc="Fraction of open stomata" ,unit="--" , plt=T) -psas09 = list(vnam="nplantco" ,desc="Plant density" ,unit="plant/m2" , plt=T) -psas10 = list(vnam="laico" ,desc="Leaf area index" ,unit="m2/m2" , plt=T) +psas01 = list(vnam="lightbeamco",desc="Downward direct light" ,unit="--" , plt=T) +psas02 = list(vnam="gppco" ,desc="Gross primary product." ,unit="kgC/plant/yr", plt=T) +psas03 = list(vnam="respco" ,desc="Total plant respiration" ,unit="kgC/plant/yr", plt=T) +psas04 = list(vnam="nppco" ,desc="Net primary productivity",unit="kgC/plant/yr", plt=T) +psas05 = list(vnam="mcostco" ,desc="Maintenance costs" ,unit="kgC/plant/yr", plt=T) +psas06 = list(vnam="ncbmortco" ,desc="Mortality due to Neg. CB",unit="1/yr" , plt=T) +psas07 = list(vnam="agbco" ,desc="Above-ground biomass" ,unit="kgC/plant" , plt=T) +psas08 = list(vnam="fsoco" ,desc="Fraction of open stomata",unit="--" , plt=T) +psas09 = list(vnam="nplantco" ,desc="Plant density" ,unit="plant/m2" , plt=T) +psas10 = list(vnam="laico" ,desc="Leaf area index" ,unit="m2/m2" , plt=T) #----- Similar to Hovmoller diagrams. -----------------------------------------------------# nhov = 4 hovdi01 = list(vnam = c("gpp","plresp","hetresp","nep") @@ -136,6 +136,7 @@ source(paste(srcdir,"pretty.time.r",sep="/")) source(paste(srcdir,"rconstants.r" ,sep="/")) source(paste(srcdir,"sombreado.r" ,sep="/")) source(paste(srcdir,"southammap.r" ,sep="/")) +source(paste(srcdir,"thermlib.r" ,sep="/")) source(paste(srcdir,"timeutils.r" ,sep="/")) #----- Define some default legend colours and names. --------------------------------------# @@ -296,7 +297,7 @@ for (ipy in 1:nplaces){ p$soil.temp = NULL p$soil.moist = NULL #----- Cohort level lists. -------------------------------------------------------------# - p$beamextco = list() + p$lightbeamco = list() p$gppco = list() p$respco = list() p$nppco = list() @@ -428,11 +429,13 @@ for (year in yeara:yearz){ # myday$DMEAN.STORAGE.RESP[ipy] - # myday$DMEAN.VLEAF.RESP [ipy] ) - p$sens = c (p$sens , myday$DMEAN.SENSIBLE.GC[ipy] - + myday$DMEAN.SENSIBLE.LC[ipy] - + myday$DMEAN.SENSIBLE.WC[ipy]) - p$evap = c (p$evap ,myday$DMEAN.EVAP [ipy] * alvl ) - p$transp = c (p$transp,myday$DMEAN.TRANSP [ipy] * alvl ) + p$sens = c (p$sens , myday$DMEAN.SENSIBLE.GC [ipy] + + myday$DMEAN.SENSIBLE.LC [ipy] + + myday$DMEAN.SENSIBLE.WC [ipy]) + p$evap = c (p$evap , myday$DMEAN.EVAP [ipy] + * alvli(myday$DMEAN.CAN.TEMP [ipy]) ) + p$transp = c (p$transp, myday$DMEAN.TRANSP [ipy] + * alvli(myday$DMEAN.CAN.TEMP [ipy]) ) p$atm.temp = c (p$atm.temp,myday$DMEAN.ATM.TEMP [ipy] - t00 ) p$atm.shv = c (p$atm.shv ,myday$DMEAN.ATM.SHV [ipy] * 1000. ) @@ -463,23 +466,24 @@ for (year in yeara:yearz){ hetresppanow = myday$DMEAN.RH.PA[apa:zpa] #----- Load the other cohort-level variables. --------------------------------# - pftconow = myday$PFT[aco:zco] - nplantconow = myday$NPLANT[aco:zco] - agbconow = myday$AGB.CO[aco:zco] - laiconow = myday$LAI.CO[aco:zco] - gppconow = myday$DMEAN.GPP.CO[aco:zco] - respconow = myday$DMEAN.LEAF.RESP.CO [aco:zco] + - myday$DMEAN.ROOT.RESP.CO [aco:zco] + - growth.resp.fac[myday$PFT[aco:zco]] * - ( myday$DMEAN.GPP.CO [aco:zco] - - myday$DMEAN.LEAF.RESP.CO[aco:zco] - - myday$DMEAN.ROOT.RESP.CO[aco:zco] ) - nppconow = gppconow-respconow - mcostconow = myday$LEAF.MAINTENANCE [aco:zco] + - myday$ROOT.MAINTENANCE [aco:zco] - ncbmortconow = myday$MORT.RATE.CO[aco:zco,2] - fsoconow = myday$DMEAN.FS.OPEN.CO[aco:zco] - beamextconow = myday$DMEAN.BEAMEXT.LEVEL[aco:zco] + pftconow = myday$PFT[aco:zco] + nplantconow = myday$NPLANT[aco:zco] + agbconow = myday$AGB.CO[aco:zco] + laiconow = myday$LAI.CO[aco:zco] + gppconow = myday$DMEAN.GPP.CO[aco:zco] + respconow = ( myday$DMEAN.LEAF.RESP.CO [aco:zco] + + myday$DMEAN.ROOT.RESP.CO [aco:zco] + + growth.resp.fac[myday$PFT[aco:zco]] + * ( myday$DMEAN.GPP.CO [aco:zco] + - myday$DMEAN.LEAF.RESP.CO[aco:zco] + - myday$DMEAN.ROOT.RESP.CO[aco:zco] ) + ) + nppconow = gppconow-respconow + mcostconow = myday$LEAF.MAINTENANCE [aco:zco] + + myday$ROOT.MAINTENANCE [aco:zco] + ncbmortconow = myday$MORT.RATE.CO[aco:zco,2] + fsoconow = myday$DMEAN.FS.OPEN.CO[aco:zco] + lightbeamconow = myday$DMEAN.LIGHTBEAM.LEVEL[aco:zco] #-----------------------------------------------------------------------------# @@ -537,33 +541,33 @@ for (year in yeara:yearz){ monyear = paste("m",cmonth,"y",year,sep="") if (day == firstday){ #----- Binding the current cohorts. ---------------------------------------# - p$beamextco[[monyear]] = beamextconow * ndaysi - p$gppco[[monyear]] = gppconow * ndaysi - p$respco[[monyear]] = respconow * ndaysi - p$nppco[[monyear]] = nppconow * ndaysi - p$mcostco[[monyear]] = mcostconow * ndaysi - p$ncbmortco[[monyear]] = ncbmortconow * ndaysi - p$agbco[[monyear]] = agbconow * ndaysi - p$fsoco[[monyear]] = fsoconow * ndaysi - p$nplantco[[monyear]] = nplantconow * ndaysi - p$dbhco[[monyear]] = dbhconow * ndaysi - p$laico[[monyear]] = laiconow * ndaysi + p$lightbeamco[[monyear]] = lightbeamconow * ndaysi + p$gppco [[monyear]] = gppconow * ndaysi + p$respco [[monyear]] = respconow * ndaysi + p$nppco [[monyear]] = nppconow * ndaysi + p$mcostco [[monyear]] = mcostconow * ndaysi + p$ncbmortco [[monyear]] = ncbmortconow * ndaysi + p$agbco [[monyear]] = agbconow * ndaysi + p$fsoco [[monyear]] = fsoconow * ndaysi + p$nplantco [[monyear]] = nplantconow * ndaysi + p$dbhco [[monyear]] = dbhconow * ndaysi + p$laico [[monyear]] = laiconow * ndaysi #----- The following variables are not averaged. --------------------------# - p$pftco[[monyear]] = pftconow - p$ageco[[monyear]] = ageconow - p$areaco[[monyear]] = areaconow + p$pftco [[monyear]] = pftconow + p$ageco [[monyear]] = ageconow + p$areaco [[monyear]] = areaconow }else{ - p$beamextco[[monyear]] = p$beamextco[[monyear]] + beamextconow * ndaysi - p$gppco[[monyear]] = p$gppco[[monyear]] + gppconow * ndaysi - p$respco[[monyear]] = p$respco[[monyear]] + respconow * ndaysi - p$nppco[[monyear]] = p$nppco[[monyear]] + nppconow * ndaysi - p$mcostco[[monyear]] = p$mcostco[[monyear]] + mcostconow * ndaysi - p$ncbmortco[[monyear]] = p$ncbmortco[[monyear]] + ncbmortconow * ndaysi - p$agbco[[monyear]] = p$agbco[[monyear]] + agbconow * ndaysi - p$fsoco[[monyear]] = p$fsoco[[monyear]] + fsoconow * ndaysi - p$nplantco[[monyear]] = p$nplantco[[monyear]] + nplantconow * ndaysi - p$dbhco[[monyear]] = p$dbhco[[monyear]] + dbhconow * ndaysi - p$laico[[monyear]] = p$laico[[monyear]] + laiconow * ndaysi + p$lightbeamco[[monyear]] = p$lightbeamco[[monyear]] + lightbeamconow*ndaysi + p$gppco [[monyear]] = p$gppco [[monyear]] + gppconow *ndaysi + p$respco [[monyear]] = p$respco [[monyear]] + respconow *ndaysi + p$nppco [[monyear]] = p$nppco [[monyear]] + nppconow *ndaysi + p$mcostco [[monyear]] = p$mcostco [[monyear]] + mcostconow *ndaysi + p$ncbmortco [[monyear]] = p$ncbmortco [[monyear]] + ncbmortconow *ndaysi + p$agbco [[monyear]] = p$agbco [[monyear]] + agbconow *ndaysi + p$fsoco [[monyear]] = p$fsoco [[monyear]] + fsoconow *ndaysi + p$nplantco [[monyear]] = p$nplantco [[monyear]] + nplantconow *ndaysi + p$dbhco [[monyear]] = p$dbhco [[monyear]] + dbhconow *ndaysi + p$laico [[monyear]] = p$laico [[monyear]] + laiconow *ndaysi } #end if month=sasmonth #-----------------------------------------------------------------------------# diff --git a/ED/Template/Template/plot_fast.r b/ED/Template/Template/plot_fast.r index 0e24236a0..717956967 100644 --- a/ED/Template/Template/plot_fast.r +++ b/ED/Template/Template/plot_fast.r @@ -1,6 +1,6 @@ #----- Here is the user-defined variable section. -----------------------------------------# here = "thispath" # Current directory. -srcdir = "/n/Moorcroft_Lab/Users/mlongo/util/Rsc" +srcdir = "/n/moorcroft_data/mlongo/util/Rsc" outroot = "thisoutroot" frqsum = 3600. @@ -192,6 +192,7 @@ source(paste(srcdir,"rconstants.r" ,sep="/")) source(paste(srcdir,"soil_coms.r" ,sep="/")) source(paste(srcdir,"sombreado.r" ,sep="/")) source(paste(srcdir,"southammap.r" ,sep="/")) +source(paste(srcdir,"thermlib.r" ,sep="/")) source(paste(srcdir,"timeutils.r" ,sep="/")) @@ -412,39 +413,46 @@ for (n in 1:ntimes){ print (paste(" # Retrieving data from ",p$lieu,"...",sep="")) - p$gpp = c(p$gpp , myfast$AVG.GPP [ipy ] ) - p$plresp = c(p$plresp , myfast$AVG.PLANT.RESP [ipy ] ) - p$hetresp = c(p$hetresp , myfast$AVG.HTROPH.RESP [ipy ] ) - p$rsnet = c(p$rsnet , myfast$AVG.RSHORT [ipy ] - * (1. - myfast$AVG.ALBEDT[ipy ]) ) - p$rlong = c(p$rlong , myfast$AVG.RLONG [ipy ] ) - p$rlongup = c(p$rlongup , myfast$AVG.RLONGUP [ipy ] ) - p$qwflxca = c(p$qwflxca ,-myfast$AVG.VAPOR.AC [ipy ] * alvl ) - p$hflxca = c(p$hflxca ,-myfast$AVG.SENSIBLE.AC [ipy ] ) - p$qwflxgc = c(p$qwflxgc , myfast$AVG.VAPOR.GC [ipy ] * alvl ) - p$qwflxac = c(p$qwflxac , myfast$AVG.VAPOR.AC [ipy ] * alvl ) - p$qwflxlc = c(p$qwflxlc , myfast$AVG.VAPOR.LC [ipy ] * alvl ) - p$qwflxwc = c(p$qwflxwc , myfast$AVG.VAPOR.WC [ipy ] * alvl ) - p$qtransp = c(p$qtransp , myfast$AVG.TRANSP [ipy ] * alvl ) - p$qdewgnd = c(p$qdewgnd ,-myfast$AVG.DEW.CG [ipy ] * alvl ) - p$hflxgc = c(p$hflxgc , myfast$AVG.SENSIBLE.GC [ipy ] ) - p$hflxac = c(p$hflxac , myfast$AVG.SENSIBLE.AC [ipy ] ) - p$hflxlc = c(p$hflxlc , myfast$AVG.SENSIBLE.LC [ipy ] ) - p$hflxwc = c(p$hflxwc , myfast$AVG.SENSIBLE.WC [ipy ] ) - p$atm.temp = c(p$atm.temp , myfast$AVG.ATM.TMP [ipy ] - t00 ) - p$can.temp = c(p$can.temp , myfast$AVG.CAN.TEMP [ipy ] - t00 ) - p$leaf.temp = c(p$leaf.temp , myfast$AVG.LEAF.TEMP [ipy ] - t00 ) - p$wood.temp = c(p$wood.temp , myfast$AVG.WOOD.TEMP [ipy ] - t00 ) - p$soil.temp = c(p$soil.temp , myfast$AVG.SOIL.TEMP [ipy,nzg] - t00 ) - p$atm.shv = c(p$atm.shv , myfast$AVG.ATM.SHV [ipy ] * 1000. ) - p$can.shv = c(p$can.shv , myfast$AVG.CAN.SHV [ipy ] * 1000. ) - p$soil.water = c(p$soil.water , myfast$AVG.SOIL.WATER [ipy,nzg] ) - p$atm.co2 = c(p$atm.co2 , myfast$AVG.ATM.CO2 [ipy ] ) - p$can.co2 = c(p$can.co2 , myfast$AVG.CAN.CO2 [ipy ] ) - p$prec = c(p$prec , myfast$AVG.PCPG [ipy ] * 3600. ) - p$intercept = c(p$intercept , myfast$AVG.INTERCEPTED [ipy ] * 3600. ) - p$throughfall = c(p$throughfall, myfast$AVG.INTERCEPTED [ipy ] * 3600. ) - p$wshed = c(p$wshed , myfast$AVG.WSHED.VG [ipy ] * 3600. ) + p$gpp = c(p$gpp , myfast$AVG.GPP [ipy ] ) + p$plresp = c(p$plresp , myfast$AVG.PLANT.RESP [ipy ] ) + p$hetresp = c(p$hetresp , myfast$AVG.HTROPH.RESP [ipy ] ) + p$rsnet = c(p$rsnet , myfast$AVG.RSHORT [ipy ] + * (1. - myfast$AVG.ALBEDT [ipy ]) ) + p$rlong = c(p$rlong , myfast$AVG.RLONG [ipy ] ) + p$rlongup = c(p$rlongup , myfast$AVG.RLONGUP [ipy ] ) + p$qwflxca = c(p$qwflxca ,-myfast$AVG.VAPOR.AC [ipy ] + * alvli(myfast$AVG.CAN.TEMP [ipy ]) ) + p$hflxca = c(p$hflxca ,-myfast$AVG.SENSIBLE.AC [ipy ] ) + p$qwflxgc = c(p$qwflxgc , myfast$AVG.VAPOR.GC [ipy ] + * alvli(myfast$AVG.CAN.TEMP [ipy ]) ) + p$qwflxac = c(p$qwflxac , myfast$AVG.VAPOR.AC [ipy ] + * alvli(myfast$AVG.CAN.TEMP [ipy ]) ) + p$qwflxlc = c(p$qwflxlc , myfast$AVG.VAPOR.LC [ipy ] + * alvli(myfast$AVG.CAN.TEMP [ipy ]) ) + p$qwflxwc = c(p$qwflxwc , myfast$AVG.VAPOR.WC [ipy ] + * alvli(myfast$AVG.CAN.TEMP [ipy ]) ) + p$qtransp = c(p$qtransp , myfast$AVG.TRANSP [ipy ] + * alvli(myfast$AVG.CAN.TEMP [ipy ]) ) + p$qdewgnd = c(p$qdewgnd ,-myfast$AVG.DEW.CG [ipy ] + * alvli(myfast$AVG.CAN.TEMP [ipy ]) ) + p$hflxgc = c(p$hflxgc , myfast$AVG.SENSIBLE.GC [ipy ] ) + p$hflxac = c(p$hflxac , myfast$AVG.SENSIBLE.AC [ipy ] ) + p$hflxlc = c(p$hflxlc , myfast$AVG.SENSIBLE.LC [ipy ] ) + p$hflxwc = c(p$hflxwc , myfast$AVG.SENSIBLE.WC [ipy ] ) + p$atm.temp = c(p$atm.temp , myfast$AVG.ATM.TMP [ipy ] - t00 ) + p$can.temp = c(p$can.temp , myfast$AVG.CAN.TEMP [ipy ] - t00 ) + p$leaf.temp = c(p$leaf.temp , myfast$AVG.LEAF.TEMP [ipy ] - t00 ) + p$wood.temp = c(p$wood.temp , myfast$AVG.WOOD.TEMP [ipy ] - t00 ) + p$soil.temp = c(p$soil.temp , myfast$AVG.SOIL.TEMP [ipy,nzg] - t00 ) + p$atm.shv = c(p$atm.shv , myfast$AVG.ATM.SHV [ipy ] * 1000. ) + p$can.shv = c(p$can.shv , myfast$AVG.CAN.SHV [ipy ] * 1000. ) + p$soil.water = c(p$soil.water , myfast$AVG.SOIL.WATER [ipy,nzg] ) + p$atm.co2 = c(p$atm.co2 , myfast$AVG.ATM.CO2 [ipy ] ) + p$can.co2 = c(p$can.co2 , myfast$AVG.CAN.CO2 [ipy ] ) + p$prec = c(p$prec , myfast$AVG.PCPG [ipy ] * 3600. ) + p$intercept = c(p$intercept , myfast$AVG.INTERCEPTED [ipy ] * 3600. ) + p$throughfall = c(p$throughfall, myfast$AVG.INTERCEPTED [ipy ] * 3600. ) + p$wshed = c(p$wshed , myfast$AVG.WSHED.VG [ipy ] * 3600. ) #------ Collecting the properties of this soil type. --------------------------------# nsoil = myfast$NTEXT.SOIL[ipy] diff --git a/ED/Template/Template/plot_monthly.r b/ED/Template/Template/plot_monthly.r index b9cfe489d..ee32f5353 100644 --- a/ED/Template/Template/plot_monthly.r +++ b/ED/Template/Template/plot_monthly.r @@ -1,7 +1,7 @@ #----- Here is the user-defined variable section. -----------------------------------------# here = "thispath" # Current directory. there = "thatpath" # Directory where analyses/history are -srcdir = "/n/Moorcroft_Lab/Users/mlongo/util/Rsc" # Source directory. +srcdir = "/n/moorcroft_data/mlongo/util/Rsc" # Source directory. outroot = "thisoutroot" monthbeg = thismontha yearbeg = thisyeara # First year to consider @@ -98,14 +98,14 @@ source(paste(srcdir,"rconstants.r" ,sep="/")) source(paste(srcdir,"soilutils.r" ,sep="/")) source(paste(srcdir,"sombreado.r" ,sep="/")) source(paste(srcdir,"southammap.r" ,sep="/")) +source(paste(srcdir,"thermlib.r" ,sep="/")) source(paste(srcdir,"timeutils.r" ,sep="/")) #----- These should be called after the others. --------------------------------------------# -source(paste(srcdir,"physiology.coms.r",sep="/")) source(paste(srcdir,"pft.coms.r" ,sep="/")) #----- Load observations. -----------------------------------------------------------------# -obsrfile = paste(srcdir,"LBA_MIP.v4.RData",sep="/") +obsrfile = paste(srcdir,"LBA_MIP.v6.RData",sep="/") load(file=obsrfile) #----- Define plot window size ------------------------------------------------------------# @@ -294,10 +294,9 @@ for (place in myplaces){ #----- Cohort level lists. -------------------------------------------------------------# lightco = list() - beamextco = list() - diffextco = list() + lightbeamco = list() + lightdiffco = list() parlco = list() - lambdaco = list() gppco = list() gpplco = list() respco = list() @@ -533,7 +532,8 @@ for (place in myplaces){ hflxlc = c(hflxlc , mymont$MMEAN.SENSIBLE.LC ) hflxwc = c(hflxwc , mymont$MMEAN.SENSIBLE.WC ) hflxgc = c(hflxgc , mymont$MMEAN.SENSIBLE.GC ) - qwflxca = c(qwflxca , - mymont$MMEAN.VAPOR.AC * alvl ) + qwflxca = c(qwflxca , - mymont$MMEAN.VAPOR.AC + * alvli(mymont$MMEAN.CAN.TEMP) ) wflxca = c(wflxca , - mymont$MMEAN.VAPOR.AC * day.sec ) wflxlc = c(wflxlc , mymont$MMEAN.VAPOR.LC * day.sec ) wflxwc = c(wflxwc , mymont$MMEAN.VAPOR.WC * day.sec ) @@ -541,24 +541,32 @@ for (place in myplaces){ evap = c(evap , mymont$MMEAN.EVAP * day.sec ) transp = c(transp , mymont$MMEAN.TRANSP * day.sec ) - mmsqu.gpp = c(mmsqu.gpp ,mymont$MMSQU.GPP ) - mmsqu.plresp = c(mmsqu.plresp ,mymont$MMSQU.PLRESP ) - mmsqu.leaf.resp = c(mmsqu.leaf.resp ,mymont$MMSQU.PLRESP ) - mmsqu.root.resp = c(mmsqu.root.resp ,mymont$MMSQU.PLRESP ) - mmsqu.hetresp = c(mmsqu.hetresp,mymont$MMSQU.RH ) - mmsqu.cflxca = c(mmsqu.cflxca ,mymont$MMSQU.CARBON.AC ) - mmsqu.cflxst = c(mmsqu.cflxst ,mymont$MMSQU.CARBON.ST ) - mmsqu.hflxca = c(mmsqu.hflxca ,mymont$MMSQU.SENSIBLE.AC ) - mmsqu.hflxlc = c(mmsqu.hflxlc ,mymont$MMSQU.SENSIBLE.LC ) - mmsqu.hflxwc = c(mmsqu.hflxwc ,mymont$MMSQU.SENSIBLE.WC ) - mmsqu.hflxgc = c(mmsqu.hflxgc ,mymont$MMSQU.SENSIBLE.GC ) - mmsqu.wflxca = c(mmsqu.wflxca ,mymont$MMSQU.VAPOR.AC * day.sec * day.sec ) - mmsqu.qwflxca = c(mmsqu.qwflxca,mymont$MMSQU.VAPOR.AC * alvl * alvl ) - mmsqu.wflxlc = c(mmsqu.wflxlc ,mymont$MMSQU.VAPOR.LC * day.sec * day.sec ) - mmsqu.wflxwc = c(mmsqu.wflxwc ,mymont$MMSQU.VAPOR.WC * day.sec * day.sec ) - mmsqu.wflxgc = c(mmsqu.wflxgc ,mymont$MMSQU.VAPOR.GC * day.sec * day.sec ) - mmsqu.evap = c(mmsqu.evap ,mymont$MMSQU.EVAP * day.sec * day.sec ) - mmsqu.transp = c(mmsqu.transp ,mymont$MMSQU.TRANSP * day.sec * day.sec ) + mmsqu.gpp = c(mmsqu.gpp , mymont$MMSQU.GPP ) + mmsqu.plresp = c(mmsqu.plresp , mymont$MMSQU.PLRESP ) + mmsqu.leaf.resp = c(mmsqu.leaf.resp , mymont$MMSQU.PLRESP ) + mmsqu.root.resp = c(mmsqu.root.resp , mymont$MMSQU.PLRESP ) + mmsqu.hetresp = c(mmsqu.hetresp , mymont$MMSQU.RH ) + mmsqu.cflxca = c(mmsqu.cflxca , mymont$MMSQU.CARBON.AC ) + mmsqu.cflxst = c(mmsqu.cflxst , mymont$MMSQU.CARBON.ST ) + mmsqu.hflxca = c(mmsqu.hflxca , mymont$MMSQU.SENSIBLE.AC ) + mmsqu.hflxlc = c(mmsqu.hflxlc , mymont$MMSQU.SENSIBLE.LC ) + mmsqu.hflxwc = c(mmsqu.hflxwc , mymont$MMSQU.SENSIBLE.WC ) + mmsqu.hflxgc = c(mmsqu.hflxgc , mymont$MMSQU.SENSIBLE.GC ) + mmsqu.wflxca = c(mmsqu.wflxca , mymont$MMSQU.VAPOR.AC + * day.sec * day.sec ) + mmsqu.qwflxca = c(mmsqu.qwflxca , mymont$MMSQU.VAPOR.AC + * alvli(mymont$MMEAN.CAN.TEMP) + * alvli(mymont$MMEAN.CAN.TEMP) ) + mmsqu.wflxlc = c(mmsqu.wflxlc , mymont$MMSQU.VAPOR.LC + * day.sec * day.sec ) + mmsqu.wflxwc = c(mmsqu.wflxwc , mymont$MMSQU.VAPOR.WC + * day.sec * day.sec ) + mmsqu.wflxgc = c(mmsqu.wflxgc , mymont$MMSQU.VAPOR.GC + * day.sec * day.sec ) + mmsqu.evap = c(mmsqu.evap , mymont$MMSQU.EVAP + * day.sec * day.sec ) + mmsqu.transp = c(mmsqu.transp , mymont$MMSQU.TRANSP + * day.sec * day.sec ) ustar = c(ustar ,mymont$MMEAN.USTAR ) @@ -634,7 +642,8 @@ for (place in myplaces){ dcycmean$hflxwc [m,] = mymont$QMEAN.SENSIBLE.WC dcycmean$hflxgc [m,] = mymont$QMEAN.SENSIBLE.GC dcycmean$wflxca [m,] = - mymont$QMEAN.VAPOR.AC * day.sec - dcycmean$qwflxca [m,] = - mymont$QMEAN.VAPOR.AC * alvl + dcycmean$qwflxca [m,] = ( - mymont$QMEAN.VAPOR.AC + * alvli(mymont$QMEAN.CAN.TEMP) ) dcycmean$wflxlc [m,] = mymont$QMEAN.VAPOR.LC * day.sec dcycmean$wflxwc [m,] = mymont$QMEAN.VAPOR.WC * day.sec dcycmean$wflxgc [m,] = mymont$QMEAN.VAPOR.GC * day.sec @@ -683,7 +692,9 @@ for (place in myplaces){ dcycmsqu$hflxwc [m,] = mymont$QMSQU.SENSIBLE.WC dcycmsqu$hflxgc [m,] = mymont$QMSQU.SENSIBLE.GC dcycmsqu$wflxca [m,] = mymont$QMSQU.VAPOR.AC * day.sec * day.sec - dcycmsqu$qwflxca [m,] = mymont$QMSQU.VAPOR.AC * alvl * alvl + dcycmsqu$qwflxca [m,] = ( mymont$QMSQU.VAPOR.AC + * alvli(mymont$QMEAN.CAN.TEMP) + * alvli(mymont$QMEAN.CAN.TEMP) ) dcycmsqu$wflxlc [m,] = mymont$QMSQU.VAPOR.WC * day.sec * day.sec dcycmsqu$wflxwc [m,] = mymont$QMSQU.VAPOR.LC * day.sec * day.sec dcycmsqu$wflxgc [m,] = mymont$QMSQU.VAPOR.GC * day.sec * day.sec @@ -769,9 +780,8 @@ for (place in myplaces){ ncbmortconow = mymont$MMEAN.MORT.RATE[,2] fsoconow = mymont$MMEAN.FS.OPEN.CO lightconow = mymont$MMEAN.LIGHT.LEVEL - lambdaconow = mymont$MMEAN.LAMBDA.LIGHT.CO - beamextconow = mymont$MMEAN.BEAMEXT.LEVEL - diffextconow = mymont$MMEAN.BEAMEXT.LEVEL + lightbeamconow = mymont$MMEAN.LIGHT.LEVEL.BEAM + lightdiffconow = mymont$MMEAN.LIGHT.LEVEL.DIFF parlconow = mymont$MMEAN.PAR.L baliveconow = mymont$BALIVE @@ -830,9 +840,8 @@ for (place in myplaces){ ncbmortconow = NA fsoconow = NA lightconow = NA - lambdaconow = NA - beamextconow = NA - diffextconow = NA + lightbeamconow = NA + lightdiffconow = NA parlconow = NA demandconow = NA supplyconow = NA @@ -1118,39 +1127,38 @@ for (place in myplaces){ cmonth = substring(100+month,2,3) labwhen = paste("y",cyear,"m",cmonth,sep="") #----- Binding the current cohorts. ------------------------------------------# - lightco [[labwhen]] = lightconow - beamextco[[labwhen]] = beamextconow - diffextco[[labwhen]] = diffextconow - parlco [[labwhen]] = parlconow - lambdaco [[labwhen]] = lambdaconow - gppco [[labwhen]] = gppconow - gpplco [[labwhen]] = gpplconow - respco [[labwhen]] = respconow - nppco [[labwhen]] = nppconow - cbrbarco [[labwhen]] = cbrbarconow - cbalco [[labwhen]] = cbalconow - mcostco [[labwhen]] = mcostconow - ncbmortco[[labwhen]] = ncbmortconow - agbco [[labwhen]] = agbconow - fsoco [[labwhen]] = fsoconow - nplantco [[labwhen]] = nplantconow * areaconow - heightco [[labwhen]] = heightconow - baco [[labwhen]] = nplantconow * baconow * areaconow - pftco [[labwhen]] = pftconow - dbhco [[labwhen]] = dbhconow - laico [[labwhen]] = laiconow - waico [[labwhen]] = waiconow - taico [[labwhen]] = taiconow - ageco [[labwhen]] = ageconow - areaco [[labwhen]] = areaconow - demandco [[labwhen]] = demandconow - supplyco [[labwhen]] = supplyconow - baliveco [[labwhen]] = baliveconow - bdeadco [[labwhen]] = bdeadconow - bleafco [[labwhen]] = bleafconow - brootco [[labwhen]] = brootconow - bswoodco [[labwhen]] = bswoodconow - bstoreco [[labwhen]] = bstoreconow + lightco [[labwhen]] = lightconow + lightbeamco [[labwhen]] = lightbeamconow + lightdiffco [[labwhen]] = lightdiffconow + parlco [[labwhen]] = parlconow + gppco [[labwhen]] = gppconow + gpplco [[labwhen]] = gpplconow + respco [[labwhen]] = respconow + nppco [[labwhen]] = nppconow + cbrbarco [[labwhen]] = cbrbarconow + cbalco [[labwhen]] = cbalconow + mcostco [[labwhen]] = mcostconow + ncbmortco [[labwhen]] = ncbmortconow + agbco [[labwhen]] = agbconow + fsoco [[labwhen]] = fsoconow + nplantco [[labwhen]] = nplantconow * areaconow + heightco [[labwhen]] = heightconow + baco [[labwhen]] = nplantconow * baconow * areaconow + pftco [[labwhen]] = pftconow + dbhco [[labwhen]] = dbhconow + laico [[labwhen]] = laiconow + waico [[labwhen]] = waiconow + taico [[labwhen]] = taiconow + ageco [[labwhen]] = ageconow + areaco [[labwhen]] = areaconow + demandco [[labwhen]] = demandconow + supplyco [[labwhen]] = supplyconow + baliveco [[labwhen]] = baliveconow + bdeadco [[labwhen]] = bdeadconow + bleafco [[labwhen]] = bleafconow + brootco [[labwhen]] = brootconow + bswoodco [[labwhen]] = bswoodconow + bstoreco [[labwhen]] = bstoreconow } #end if month=sasmonth #--------------------------------------------------------------------------------# @@ -1173,61 +1181,61 @@ for (place in myplaces){ print (" - Finding the monthly mean...") print (" * Aggregating the monthly mean...") mont12mn = list() - mont12mn$gpp = tapply(X=gpp ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$npp = tapply(X=npp ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$nep = tapply(X=nep ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$plresp = tapply(X=plresp ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$leaf.resp = tapply(X=leaf.resp ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$root.resp = tapply(X=root.resp ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$growth.resp = tapply(X=growth.resp ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$hetresp = tapply(X=hetresp ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$cflxca = tapply(X=cflxca ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$cflxst = tapply(X=cflxst ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$nee = tapply(X=nee ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$hflxca = tapply(X=hflxca ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$hflxlc = tapply(X=hflxlc ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$hflxwc = tapply(X=hflxwc ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$hflxgc = tapply(X=hflxgc ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$wflxca = tapply(X=wflxca ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$qwflxca = tapply(X=qwflxca ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$wflxlc = tapply(X=wflxlc ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$wflxwc = tapply(X=wflxwc ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$wflxgc = tapply(X=wflxgc ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$evap = tapply(X=evap ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$transp = tapply(X=transp ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$rain = tapply(X=rain ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$atm.temp = tapply(X=atm.temp ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$rshort = tapply(X=rshort ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$rlong = tapply(X=rlong ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$atm.shv = tapply(X=atm.shv ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$atm.co2 = tapply(X=atm.co2 ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$atm.prss = tapply(X=atm.prss ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$atm.vels = tapply(X=atm.vels ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$ustar = tapply(X=ustar ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12mn$soil.temp = qapply(mat=soil.temp ,index=mfac,bycol=T,func=mean,na.rm=T) - mont12mn$soil.water = qapply(mat=soil.water ,index=mfac,bycol=T,func=mean,na.rm=T) - mont12mn$soil.mstpot = qapply(mat=soil.mstpot,index=mfac,bycol=T,func=mean,na.rm=T) + mont12mn$gpp = tapply(X=gpp ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$npp = tapply(X=npp ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$nep = tapply(X=nep ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$plresp = tapply(X=plresp ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$leaf.resp = tapply(X=leaf.resp ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$root.resp = tapply(X=root.resp ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$growth.resp = tapply(X=growth.resp ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$hetresp = tapply(X=hetresp ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$cflxca = tapply(X=cflxca ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$cflxst = tapply(X=cflxst ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$nee = tapply(X=nee ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$hflxca = tapply(X=hflxca ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$hflxlc = tapply(X=hflxlc ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$hflxwc = tapply(X=hflxwc ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$hflxgc = tapply(X=hflxgc ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$wflxca = tapply(X=wflxca ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$qwflxca = tapply(X=qwflxca ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$wflxlc = tapply(X=wflxlc ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$wflxwc = tapply(X=wflxwc ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$wflxgc = tapply(X=wflxgc ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$evap = tapply(X=evap ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$transp = tapply(X=transp ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$rain = tapply(X=rain ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$atm.temp = tapply(X=atm.temp ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$rshort = tapply(X=rshort ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$rlong = tapply(X=rlong ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$atm.shv = tapply(X=atm.shv ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$atm.co2 = tapply(X=atm.co2 ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$atm.prss = tapply(X=atm.prss ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$atm.vels = tapply(X=atm.vels ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$ustar = tapply(X=ustar ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12mn$soil.temp = qapply(X=soil.temp ,INDEX=mfac,DIM=1,FUN=mean,na.rm=TRUE) + mont12mn$soil.water = qapply(X=soil.water ,INDEX=mfac,DIM=1,FUN=mean,na.rm=TRUE) + mont12mn$soil.mstpot = qapply(X=soil.mstpot ,INDEX=mfac,DIM=1,FUN=mean,na.rm=TRUE) #----- Find the mean sum of squares. ---------------------------------------------------# print (" * Aggregating the monthly mean sum of squares...") mont12sq = list() - mont12sq$gpp = tapply(X=mmsqu.gpp ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12sq$plresp = tapply(X=mmsqu.plresp ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12sq$leaf.resp = tapply(X=mmsqu.leaf.resp ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12sq$root.resp = tapply(X=mmsqu.root.resp ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12sq$hetresp = tapply(X=mmsqu.hetresp ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12sq$cflxca = tapply(X=mmsqu.cflxca ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12sq$cflxst = tapply(X=mmsqu.cflxst ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12sq$hflxca = tapply(X=mmsqu.hflxca ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12sq$hflxlc = tapply(X=mmsqu.hflxlc ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12sq$hflxwc = tapply(X=mmsqu.hflxwc ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12sq$hflxgc = tapply(X=mmsqu.hflxgc ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12sq$wflxca = tapply(X=mmsqu.wflxca ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12sq$qwflxca = tapply(X=mmsqu.qwflxca ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12sq$wflxlc = tapply(X=mmsqu.wflxlc ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12sq$wflxwc = tapply(X=mmsqu.wflxwc ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12sq$wflxgc = tapply(X=mmsqu.wflxgc ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12sq$evap = tapply(X=mmsqu.evap ,INDEX=mfac,FUN=mean,na.rm=TRUE) - mont12sq$transp = tapply(X=mmsqu.transp ,INDEX=mfac,FUN=mean,na.rm=TRUE) + mont12sq$gpp = tapply(X=mmsqu.gpp ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12sq$plresp = tapply(X=mmsqu.plresp ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12sq$leaf.resp = tapply(X=mmsqu.leaf.resp ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12sq$root.resp = tapply(X=mmsqu.root.resp ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12sq$hetresp = tapply(X=mmsqu.hetresp ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12sq$cflxca = tapply(X=mmsqu.cflxca ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12sq$cflxst = tapply(X=mmsqu.cflxst ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12sq$hflxca = tapply(X=mmsqu.hflxca ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12sq$hflxlc = tapply(X=mmsqu.hflxlc ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12sq$hflxwc = tapply(X=mmsqu.hflxwc ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12sq$hflxgc = tapply(X=mmsqu.hflxgc ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12sq$wflxca = tapply(X=mmsqu.wflxca ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12sq$qwflxca = tapply(X=mmsqu.qwflxca ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12sq$wflxlc = tapply(X=mmsqu.wflxlc ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12sq$wflxwc = tapply(X=mmsqu.wflxwc ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12sq$wflxgc = tapply(X=mmsqu.wflxgc ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12sq$evap = tapply(X=mmsqu.evap ,INDEX=mfac ,FUN=mean,na.rm=TRUE) + mont12sq$transp = tapply(X=mmsqu.transp ,INDEX=mfac ,FUN=mean,na.rm=TRUE) #---------------------------------------------------------------------------------------# # Here we convert the sum of squares into standard deviation. The standard devi- # # ation can be written in two different ways, and we will use the latter because it # @@ -1299,77 +1307,77 @@ for (place in myplaces){ # deviation. # #---------------------------------------------------------------------------------------# print (" - Aggregating the monthly mean of the diurnal cycle...") - dcyc12mn = list() - dcyc12mn$gpp = qapply(dcycmean$gpp ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$npp = qapply(dcycmean$npp ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$plresp = qapply(dcycmean$plresp ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$leaf.resp = qapply(dcycmean$leaf.resp ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$root.resp = qapply(dcycmean$root.resp ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$hetresp = qapply(dcycmean$hetresp ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$nep = qapply(dcycmean$nep ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$nee = qapply(dcycmean$nee ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$cflxca = qapply(dcycmean$cflxca ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$cflxst = qapply(dcycmean$cflxst ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$hflxca = qapply(dcycmean$hflxca ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$hflxlc = qapply(dcycmean$hflxlc ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$hflxwc = qapply(dcycmean$hflxwc ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$hflxgc = qapply(dcycmean$hflxgc ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$wflxca = qapply(dcycmean$wflxca ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$qwflxca = qapply(dcycmean$qwflxca ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$wflxlc = qapply(dcycmean$wflxlc ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$wflxwc = qapply(dcycmean$wflxwc ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$wflxgc = qapply(dcycmean$wflxgc ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$evap = qapply(dcycmean$evap ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$transp = qapply(dcycmean$transp ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$atm.temp = qapply(dcycmean$atm.temp ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$can.temp = qapply(dcycmean$can.temp ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$leaf.temp = qapply(dcycmean$leaf.temp ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$wood.temp = qapply(dcycmean$wood.temp ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$gnd.temp = qapply(dcycmean$gnd.temp ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$atm.shv = qapply(dcycmean$atm.shv ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$can.shv = qapply(dcycmean$can.shv ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$gnd.shv = qapply(dcycmean$gnd.shv ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$atm.co2 = qapply(dcycmean$atm.co2 ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$can.co2 = qapply(dcycmean$can.co2 ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$atm.prss = qapply(dcycmean$atm.prss ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$can.prss = qapply(dcycmean$can.prss ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$atm.vels = qapply(dcycmean$atm.vels ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$ustar = qapply(dcycmean$ustar ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$fs.open = qapply(dcycmean$fs.open ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$rain = qapply(dcycmean$rain ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$rshort = qapply(dcycmean$rshort ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$rshort.beam = qapply(dcycmean$rshort.beam ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$rshort.diff = qapply(dcycmean$rshort.diff ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$rlong = qapply(dcycmean$rlong ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$rshort.gnd = qapply(dcycmean$rshort.gnd ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$rlong.gnd = qapply(dcycmean$rlong.gnd ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$rlongup = qapply(dcycmean$rlongup ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$albedo = qapply(dcycmean$albedo ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$albedo.beam = qapply(dcycmean$albedo.beam ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$albedo.diff = qapply(dcycmean$albedo.diff ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12mn$rlong.albedo= qapply(dcycmean$rlong.albedo,index=mfac,bycol=T,func=mean,na.rm=T) + dcyc12mn =list() + dcyc12mn$gpp =qapply(X=dcycmean$gpp ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$npp =qapply(X=dcycmean$npp ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$plresp =qapply(X=dcycmean$plresp ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$leaf.resp =qapply(X=dcycmean$leaf.resp ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$root.resp =qapply(X=dcycmean$root.resp ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$hetresp =qapply(X=dcycmean$hetresp ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$nep =qapply(X=dcycmean$nep ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$nee =qapply(X=dcycmean$nee ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$cflxca =qapply(X=dcycmean$cflxca ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$cflxst =qapply(X=dcycmean$cflxst ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$hflxca =qapply(X=dcycmean$hflxca ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$hflxlc =qapply(X=dcycmean$hflxlc ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$hflxwc =qapply(X=dcycmean$hflxwc ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$hflxgc =qapply(X=dcycmean$hflxgc ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$wflxca =qapply(X=dcycmean$wflxca ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$qwflxca =qapply(X=dcycmean$qwflxca ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$wflxlc =qapply(X=dcycmean$wflxlc ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$wflxwc =qapply(X=dcycmean$wflxwc ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$wflxgc =qapply(X=dcycmean$wflxgc ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$evap =qapply(X=dcycmean$evap ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$transp =qapply(X=dcycmean$transp ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$atm.temp =qapply(X=dcycmean$atm.temp ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$can.temp =qapply(X=dcycmean$can.temp ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$leaf.temp =qapply(X=dcycmean$leaf.temp ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$wood.temp =qapply(X=dcycmean$wood.temp ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$gnd.temp =qapply(X=dcycmean$gnd.temp ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$atm.shv =qapply(X=dcycmean$atm.shv ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$can.shv =qapply(X=dcycmean$can.shv ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$gnd.shv =qapply(X=dcycmean$gnd.shv ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$atm.co2 =qapply(X=dcycmean$atm.co2 ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$can.co2 =qapply(X=dcycmean$can.co2 ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$atm.prss =qapply(X=dcycmean$atm.prss ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$can.prss =qapply(X=dcycmean$can.prss ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$atm.vels =qapply(X=dcycmean$atm.vels ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$ustar =qapply(X=dcycmean$ustar ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$fs.open =qapply(X=dcycmean$fs.open ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$rain =qapply(X=dcycmean$rain ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$rshort =qapply(X=dcycmean$rshort ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$rshort.beam =qapply(X=dcycmean$rshort.beam ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$rshort.diff =qapply(X=dcycmean$rshort.diff ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$rlong =qapply(X=dcycmean$rlong ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$rshort.gnd =qapply(X=dcycmean$rshort.gnd ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$rlong.gnd =qapply(X=dcycmean$rlong.gnd ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$rlongup =qapply(X=dcycmean$rlongup ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$albedo =qapply(X=dcycmean$albedo ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$albedo.beam =qapply(X=dcycmean$albedo.beam ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$albedo.diff =qapply(X=dcycmean$albedo.diff ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12mn$rlong.albedo=qapply(X=dcycmean$rlong.albedo,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) #----- Find the mean sum of squares. ---------------------------------------------------# print (" - Aggregating the monthly mean sum of squares...") dcyc12sq = list() - dcyc12sq$gpp = qapply(dcycmsqu$gpp ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12sq$plresp = qapply(dcycmsqu$plresp ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12sq$leaf.resp = qapply(dcycmsqu$leaf.resp ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12sq$root.resp = qapply(dcycmsqu$root.resp ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12sq$hetresp = qapply(dcycmsqu$hetresp ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12sq$nep = qapply(dcycmsqu$nep ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12sq$cflxca = qapply(dcycmsqu$cflxca ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12sq$cflxst = qapply(dcycmsqu$cflxst ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12sq$hflxca = qapply(dcycmsqu$hflxca ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12sq$hflxlc = qapply(dcycmsqu$hflxlc ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12sq$hflxwc = qapply(dcycmsqu$hflxwc ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12sq$hflxgc = qapply(dcycmsqu$hflxgc ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12sq$wflxca = qapply(dcycmsqu$wflxca ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12sq$qwflxca = qapply(dcycmsqu$qwflxca ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12sq$wflxlc = qapply(dcycmsqu$wflxlc ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12sq$wflxwc = qapply(dcycmsqu$wflxwc ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12sq$wflxgc = qapply(dcycmsqu$wflxgc ,index=mfac,bycol=T,func=mean,na.rm=T) - dcyc12sq$transp = qapply(dcycmsqu$transp ,index=mfac,bycol=T,func=mean,na.rm=T) + dcyc12sq$gpp = qapply(X=dcycmsqu$gpp ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12sq$plresp = qapply(X=dcycmsqu$plresp ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12sq$leaf.resp = qapply(X=dcycmsqu$leaf.resp ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12sq$root.resp = qapply(X=dcycmsqu$root.resp ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12sq$hetresp = qapply(X=dcycmsqu$hetresp ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12sq$nep = qapply(X=dcycmsqu$nep ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12sq$cflxca = qapply(X=dcycmsqu$cflxca ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12sq$cflxst = qapply(X=dcycmsqu$cflxst ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12sq$hflxca = qapply(X=dcycmsqu$hflxca ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12sq$hflxlc = qapply(X=dcycmsqu$hflxlc ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12sq$hflxwc = qapply(X=dcycmsqu$hflxwc ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12sq$hflxgc = qapply(X=dcycmsqu$hflxgc ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12sq$wflxca = qapply(X=dcycmsqu$wflxca ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12sq$qwflxca = qapply(X=dcycmsqu$qwflxca ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12sq$wflxlc = qapply(X=dcycmsqu$wflxlc ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12sq$wflxwc = qapply(X=dcycmsqu$wflxwc ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12sq$wflxgc = qapply(X=dcycmsqu$wflxgc ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) + dcyc12sq$transp = qapply(X=dcycmsqu$transp ,INDEX=mfac,DIM=1,FUN=mean,na.rm=T) #---------------------------------------------------------------------------------------# # Here we convert the sum of squares into standard deviation. The standard devi- # diff --git a/ED/Template/Template/plot_photo.r b/ED/Template/Template/plot_photo.r index 82188a345..66c8e14a0 100644 --- a/ED/Template/Template/plot_photo.r +++ b/ED/Template/Template/plot_photo.r @@ -1,6 +1,6 @@ #----- Here is the user-defined variable section. -----------------------------------------# here = "thispath" # Current directory. -srcdir = "/n/Moorcroft_Lab/Users/mlongo/util/Rsc" # Source directory. +srcdir = "/n/moorcroft_data/mlongo/util/Rsc" # Source directory. outroot = "thisoutroot" # Source directory. myplaces = c("thispoly") iphoto = myphysiol @@ -263,6 +263,9 @@ options(locatorBell=FALSE) #------------------------------------------------------------------------------------------# +jallom = c(0,0,1,1,2) +iallom = jallom[iallom] + #----- Load some files with global constants. ---------------------------------------------# source(paste(srcdir,"allometry.r",sep="/")) diff --git a/ED/Template/Template/plot_rk4.r b/ED/Template/Template/plot_rk4.r index cf4dc7a3a..d0c0d0999 100644 --- a/ED/Template/Template/plot_rk4.r +++ b/ED/Template/Template/plot_rk4.r @@ -1,6 +1,6 @@ #----- Here is the user-defined variable section. -----------------------------------------# here = "thispath" # Current directory. -srcdir = "/n/Moorcroft_Lab/Users/mlongo/util/Rsc" # Source directory. +srcdir = "/n/moorcroft_data/mlongo/util/Rsc" # Source directory. outroot = "thisoutroot" # Source directory. myplaces = c("thispoly") #------------------------------------------------------------------------------------------# @@ -411,18 +411,19 @@ options(locatorBell=FALSE) #----- Loading some files with functions. -------------------------------------------------# -source(paste(srcdir,"atlas.r",sep="/")) -source(paste(srcdir,"globdims.r",sep="/")) -source(paste(srcdir,"locations.r",sep="/")) -source(paste(srcdir,"muitas.r",sep="/")) -source(paste(srcdir,"pretty.log.r",sep="/")) +source(paste(srcdir,"atlas.r" ,sep="/")) +source(paste(srcdir,"globdims.r" ,sep="/")) +source(paste(srcdir,"locations.r" ,sep="/")) +source(paste(srcdir,"muitas.r" ,sep="/")) +source(paste(srcdir,"pretty.log.r" ,sep="/")) source(paste(srcdir,"pretty.time.r",sep="/")) -source(paste(srcdir,"plotsize.r",sep="/")) -source(paste(srcdir,"qapply.r",sep="/")) -source(paste(srcdir,"rconstants.r",sep="/")) -source(paste(srcdir,"sombreado.r",sep="/")) -source(paste(srcdir,"southammap.r",sep="/")) -source(paste(srcdir,"timeutils.r",sep="/")) +source(paste(srcdir,"plotsize.r" ,sep="/")) +source(paste(srcdir,"qapply.r" ,sep="/")) +source(paste(srcdir,"rconstants.r" ,sep="/")) +source(paste(srcdir,"sombreado.r" ,sep="/")) +source(paste(srcdir,"southammap.r" ,sep="/")) +source(paste(srcdir,"thermlib.r" ,sep="/")) +source(paste(srcdir,"timeutils.r" ,sep="/")) #------------------------------------------------------------------------------------------# @@ -560,7 +561,7 @@ for (place in myplaces){ cpatch$transp = cpatch$transp * day.sec #----- Canopy -> Atmosphere fluxes in W/m2. -----------------------------------------# - cpatch$qwflxca = - cpatch$wflxac * alvl / day.sec + cpatch$qwflxca = - cpatch$wflxac * alvli(cpatch$can.temp) / day.sec cpatch$hflxca = - cpatch$hflxac cpatch$cflxca = - cpatch$cflxac diff --git a/ED/Template/Template/plot_rk4pc.r b/ED/Template/Template/plot_rk4pc.r index fcdc1659b..396a52207 100644 --- a/ED/Template/Template/plot_rk4pc.r +++ b/ED/Template/Template/plot_rk4pc.r @@ -1,6 +1,6 @@ #----- Here is the user-defined variable section. -----------------------------------------# here = "thispath" # Current directory. -srcdir = "/n/Moorcroft_Lab/Users/mlongo/util/Rsc" # Source directory. +srcdir = "/n/moorcroft_data/mlongo/util/Rsc" # Source directory. outroot = "thisoutroot" # Source directory. myplaces = c("thispoly") #------------------------------------------------------------------------------------------# @@ -573,18 +573,19 @@ options(locatorBell=FALSE) #----- Loading some files with functions. -------------------------------------------------# -source(paste(srcdir,"atlas.r",sep="/")) -source(paste(srcdir,"globdims.r",sep="/")) -source(paste(srcdir,"locations.r",sep="/")) -source(paste(srcdir,"muitas.r",sep="/")) -source(paste(srcdir,"pretty.log.r",sep="/")) +source(paste(srcdir,"atlas.r" ,sep="/")) +source(paste(srcdir,"globdims.r" ,sep="/")) +source(paste(srcdir,"locations.r" ,sep="/")) +source(paste(srcdir,"muitas.r" ,sep="/")) +source(paste(srcdir,"pretty.log.r" ,sep="/")) source(paste(srcdir,"pretty.time.r",sep="/")) -source(paste(srcdir,"plotsize.r",sep="/")) -source(paste(srcdir,"qapply.r",sep="/")) -source(paste(srcdir,"rconstants.r",sep="/")) -source(paste(srcdir,"sombreado.r",sep="/")) -source(paste(srcdir,"southammap.r",sep="/")) -source(paste(srcdir,"timeutils.r",sep="/")) +source(paste(srcdir,"plotsize.r" ,sep="/")) +source(paste(srcdir,"qapply.r" ,sep="/")) +source(paste(srcdir,"rconstants.r" ,sep="/")) +source(paste(srcdir,"sombreado.r" ,sep="/")) +source(paste(srcdir,"southammap.r" ,sep="/")) +source(paste(srcdir,"thermlib.r" ,sep="/")) +source(paste(srcdir,"timeutils.r" ,sep="/")) #------------------------------------------------------------------------------------------# @@ -735,7 +736,7 @@ for (place in myplaces){ cpatch$transp = cpatch$transp * day.sec #----- Canopy -> Atmosphere fluxes in W/m2. -----------------------------------------# - cpatch$qwflxca = -cpatch$wflxac * alvl / day.sec + cpatch$qwflxca = -cpatch$wflxac * alvli(cpatch$can.temp) / day.sec cpatch$hflxca = -cpatch$hflxac cpatch$cflxca = -cpatch$cflxac diff --git a/ED/Template/Template/purge.sh b/ED/Template/Template/purge.sh index ee1b250b0..1768db88d 100755 --- a/ED/Template/Template/purge.sh +++ b/ED/Template/Template/purge.sh @@ -7,7 +7,8 @@ then mkdir analy mkdir histo mkdir output - rm -fv core.* fort.* *_out.out *_lsf.out *_out.err thermo_state_* photo_state_* + rm -fv core.* fort.* *_out.out *_lsf.out *_out.err + rm -fv budget_state_* thermo_state_* photo_state_* else rm -fvr analy rm -fvr histo @@ -15,5 +16,6 @@ else mkdir analy mkdir histo mkdir output - rm -fv core.* fort.* *_out.out *_lsf.out *_out.err thermo_state_* photo_state_* + rm -fv core.* fort.* *_out.out *_lsf.out *_out.err + rm -fv budget_* thermo_state_* photo_state_* fi diff --git a/ED/Template/Template/reject_ed.r b/ED/Template/Template/reject_ed.r index c98f7832c..1465d9674 100644 --- a/ED/Template/Template/reject_ed.r +++ b/ED/Template/Template/reject_ed.r @@ -1,6 +1,6 @@ #----- Here is the user-defined variable section. -----------------------------------------# here = "thispath" # Current directory. -srcdir = "/n/Moorcroft_Lab/Users/mlongo/util/Rsc" # Source directory. +srcdir = "/n/moorcroft_data/mlongo/util/Rsc" # Source directory. outroot = "thisoutroot" myplaces = c("thispoly") outform = "png" # Formats for output file. Supported formats are: @@ -315,7 +315,7 @@ for (place in myplaces){ yyyymm = paste(errmaxraw[,"year"] ,substring(100+errmaxraw[,"mon"],2,3),sep="-") #----- Monthly totals. -----------------------------------------------------------------# - tserrmax = qapply(mat=errmaxraw,index=yyyymm,bycol=TRUE,func=sum) + tserrmax = qapply(X=errmaxraw,INDEX=yyyymm,DIM=1,FUN=sum) tserrmax = data.frame(tserrmax) yyyymm = unique(yyyymm) tserrmax$year = as.numeric(substring(yyyymm,1,4)) @@ -323,7 +323,7 @@ for (place in myplaces){ tserrmax$day = 15 #----- Monthly means. ------------------------------------------------------------------# mon = tserrmax$mon - cyerrmax = qapply(mat=tserrmax,index=mon,bycol=TRUE,func=mean) + cyerrmax = qapply(X=tserrmax,INDEX=mon,DIM=1,FUN=mean) cyerrmax = data.frame(cyerrmax) mon = unique(mon) cyerrmax$mon = mon @@ -345,7 +345,7 @@ for (place in myplaces){ yyyymm = paste(sanchkraw[,"year"] ,substring(100+sanchkraw[,"mon"],2,3),sep="-") #----- Monthly totals. -----------------------------------------------------------------# - tssanchk = qapply(mat=sanchkraw,index=yyyymm,bycol=TRUE,func=sum) + tssanchk = qapply(X=sanchkraw,INDEX=yyyymm,DIM=1,FUN=sum) tssanchk = data.frame(tssanchk) yyyymm = unique(yyyymm) tssanchk$year = as.numeric(substring(yyyymm,1,4)) @@ -353,7 +353,7 @@ for (place in myplaces){ tssanchk$day = 15 #----- Monthly means. ------------------------------------------------------------------# mon = tssanchk$mon - cysanchk = qapply(mat=tssanchk,index=mon,bycol=TRUE,func=mean) + cysanchk = qapply(X=tssanchk,INDEX=mon,DIM=1,FUN=mean) cysanchk = data.frame(cysanchk) mon = unique(mon) cysanchk$mon = mon diff --git a/ED/Template/bringlast.sh b/ED/Template/bringlast.sh new file mode 100755 index 000000000..944a82fcf --- /dev/null +++ b/ED/Template/bringlast.sh @@ -0,0 +1,137 @@ +#!/bin/sh +here=`pwd` +moi=`whoami` +diskthere='/n/moorcroftfs2' +lonlat=${here}'/joborder.txt' + +#----- Find the output path (both local and remote paths will be cleaned). ----------------# +basehere=`basename ${here}` +dirhere=`dirname ${here}` +while [ ${basehere} != ${moi} ] +do + basehere=`basename ${dirhere}` + dirhere=`dirname ${dirhere}` +done +diskhere=${dirhere} +echo '-------------------------------------------------------------------------------' +echo ' - Simulation control on disk: '${diskhere} +echo ' - Output on disk: '${diskthere} +echo '-------------------------------------------------------------------------------' +there=`echo ${here} | sed s@${diskhere}@${diskthere}@g` +#------------------------------------------------------------------------------------------# + + + + +#----- Determine the number of polygons to run. -------------------------------------------# +let npolys=`wc -l ${lonlat} | awk '{print $1 }'`-3 +#------------------------------------------------------------------------------------------# + + + +#------------------------------------------------------------------------------------------# +# Loop over all polygons. # +#------------------------------------------------------------------------------------------# +ff=0 +while [ ${ff} -lt ${npolys} ] +do + let ff=${ff}+1 + let line=${ff}+3 + #---------------------------------------------------------------------------------------# + # Read the ffth line of the polygon list. There must be smarter ways of doing # + # this, but this works. Here we obtain the polygon name, and its longitude and # + # latitude. # + #---------------------------------------------------------------------------------------# + oi=`head -${line} ${lonlat} | tail -1` + polyname=`echo ${oi} | awk '{print $1 }'` + polyiata=`echo ${oi} | awk '{print $2 }'` + polylon=`echo ${oi} | awk '{print $3 }'` + polylat=`echo ${oi} | awk '{print $4 }'` + yeara=`echo ${oi} | awk '{print $5 }'` + montha=`echo ${oi} | awk '{print $6 }'` + datea=`echo ${oi} | awk '{print $7 }'` + timea=`echo ${oi} | awk '{print $8 }'` + yearz=`echo ${oi} | awk '{print $9 }'` + monthz=`echo ${oi} | awk '{print $10}'` + datez=`echo ${oi} | awk '{print $11}'` + timez=`echo ${oi} | awk '{print $12}'` + polyisoil=`echo ${oi} | awk '{print $13}'` + polyntext=`echo ${oi} | awk '{print $14}'` + polysand=`echo ${oi} | awk '{print $15}'` + polyclay=`echo ${oi} | awk '{print $16}'` + polydepth=`echo ${oi} | awk '{print $17}'` + polycol=`echo ${oi} | awk '{print $18}'` + slzres=`echo ${oi} | awk '{print $19}'` + queue=`echo ${oi} | awk '{print $20}'` + metdriver=`echo ${oi} | awk '{print $21}'` + dtlsm=`echo ${oi} | awk '{print $22}'` + vmfactc3=`echo ${oi} | awk '{print $23}'` + vmfactc4=`echo ${oi} | awk '{print $24}'` + mphototrc3=`echo ${oi} | awk '{print $25}'` + mphototec3=`echo ${oi} | awk '{print $26}'` + mphotoc4=`echo ${oi} | awk '{print $27}'` + bphotoblc3=`echo ${oi} | awk '{print $28}'` + bphotonlc3=`echo ${oi} | awk '{print $29}'` + bphotoc4=`echo ${oi} | awk '{print $30}'` + kwgrass=`echo ${oi} | awk '{print $31}'` + kwtree=`echo ${oi} | awk '{print $32}'` + gammac3=`echo ${oi} | awk '{print $33}'` + gammac4=`echo ${oi} | awk '{print $34}'` + d0grass=`echo ${oi} | awk '{print $35}'` + d0tree=`echo ${oi} | awk '{print $36}'` + alphac3=`echo ${oi} | awk '{print $37}'` + alphac4=`echo ${oi} | awk '{print $38}'` + klowco2=`echo ${oi} | awk '{print $39}'` + rrffact=`echo ${oi} | awk '{print $40}'` + growthresp=`echo ${oi} | awk '{print $41}'` + lwidthgrass=`echo ${oi} | awk '{print $42}'` + lwidthbltree=`echo ${oi} | awk '{print $43}'` + lwidthnltree=`echo ${oi} | awk '{print $44}'` + q10c3=`echo ${oi} | awk '{print $45}'` + q10c4=`echo ${oi} | awk '{print $46}'` + h2olimit=`echo ${oi} | awk '{print $47}'` + isfclyrm=`echo ${oi} | awk '{print $48}'` + icanturb=`echo ${oi} | awk '{print $49}'` + ubmin=`echo ${oi} | awk '{print $50}'` + ugbmin=`echo ${oi} | awk '{print $51}'` + ustmin=`echo ${oi} | awk '{print $52}'` + gamm=`echo ${oi} | awk '{print $53}'` + gamh=`echo ${oi} | awk '{print $54}'` + tprandtl=`echo ${oi} | awk '{print $55}'` + ribmax=`echo ${oi} | awk '{print $56}'` + atmco2=`echo ${oi} | awk '{print $57}'` + thcrit=`echo ${oi} | awk '{print $58}'` + smfire=`echo ${oi} | awk '{print $59}'` + ifire=`echo ${oi} | awk '{print $60}'` + fireparm=`echo ${oi} | awk '{print $61}'` + ipercol=`echo ${oi} | awk '{print $62}'` + isoilbc=`echo ${oi} | awk '{print $63}'` + runoff=`echo ${oi} | awk '{print $64}'` + imetrad=`echo ${oi} | awk '{print $65}'` + ibranch=`echo ${oi} | awk '{print $66}'` + icanrad=`echo ${oi} | awk '{print $67}'` + crown=`echo ${oi} | awk '{print $68}'` + ltransvis=`echo ${oi} | awk '{print $69}'` + lreflectvis=`echo ${oi} | awk '{print $70}'` + ltransnir=`echo ${oi} | awk '{print $71}'` + lreflectnir=`echo ${oi} | awk '{print $72}'` + orienttree=`echo ${oi} | awk '{print $73}'` + orientgrass=`echo ${oi} | awk '{print $74}'` + clumptree=`echo ${oi} | awk '{print $75}'` + clumpgrass=`echo ${oi} | awk '{print $76}'` + ivegtdyn=`echo ${oi} | awk '{print $77}'` + igndvap=`echo ${oi} | awk '{print $78}'` + iphen=`echo ${oi} | awk '{print $79}'` + iallom=`echo ${oi} | awk '{print $80}'` + ibigleaf=`echo ${oi} | awk '{print $81}'` + irepro=`echo ${oi} | awk '{print $82}'` + #---------------------------------------------------------------------------------------# + + + #----- Find out the last history file in the directory. --------------------------------# + lasthist=`ls -1 ${there}'/'${polyname}'/histo' | grep "\-S\-" | tail -1` + echo 'Bringing a copy of '${lasthist}' to the local disk...' + /bin/cp -u ${there}'/'${polyname}'/histo/'${lasthist} ${here}'/'${polyname}'/histo' + #---------------------------------------------------------------------------------------# +done +#------------------------------------------------------------------------------------------# diff --git a/ED/Template/check_run.sh b/ED/Template/check_run.sh index 72401b520..364586485 100755 --- a/ED/Template/check_run.sh +++ b/ED/Template/check_run.sh @@ -105,23 +105,29 @@ do atmco2=`echo ${oi} | awk '{print $57}'` thcrit=`echo ${oi} | awk '{print $58}'` smfire=`echo ${oi} | awk '{print $59}'` - isoilbc=`echo ${oi} | awk '{print $60}'` - imetrad=`echo ${oi} | awk '{print $61}'` - ibranch=`echo ${oi} | awk '{print $62}'` - icanrad=`echo ${oi} | awk '{print $63}'` - crown=`echo ${oi} | awk '{print $64}'` - ltransvis=`echo ${oi} | awk '{print $65}'` - lreflectvis=`echo ${oi} | awk '{print $66}'` - ltransnir=`echo ${oi} | awk '{print $67}'` - lreflectnir=`echo ${oi} | awk '{print $68}'` - orienttree=`echo ${oi} | awk '{print $69}'` - orientgrass=`echo ${oi} | awk '{print $70}'` - clumptree=`echo ${oi} | awk '{print $71}'` - clumpgrass=`echo ${oi} | awk '{print $72}'` - ivegtdyn=`echo ${oi} | awk '{print $73}'` - igndvap=`echo ${oi} | awk '{print $74}'` - iphen=`echo ${oi} | awk '{print $75}'` - iallom=`echo ${oi} | awk '{print $76}'` + ifire=`echo ${oi} | awk '{print $60}'` + fireparm=`echo ${oi} | awk '{print $61}'` + ipercol=`echo ${oi} | awk '{print $62}'` + isoilbc=`echo ${oi} | awk '{print $63}'` + runoff=`echo ${oi} | awk '{print $64}'` + imetrad=`echo ${oi} | awk '{print $65}'` + ibranch=`echo ${oi} | awk '{print $66}'` + icanrad=`echo ${oi} | awk '{print $67}'` + crown=`echo ${oi} | awk '{print $68}'` + ltransvis=`echo ${oi} | awk '{print $69}'` + lreflectvis=`echo ${oi} | awk '{print $70}'` + ltransnir=`echo ${oi} | awk '{print $71}'` + lreflectnir=`echo ${oi} | awk '{print $72}'` + orienttree=`echo ${oi} | awk '{print $73}'` + orientgrass=`echo ${oi} | awk '{print $74}'` + clumptree=`echo ${oi} | awk '{print $75}'` + clumpgrass=`echo ${oi} | awk '{print $76}'` + ivegtdyn=`echo ${oi} | awk '{print $77}'` + igndvap=`echo ${oi} | awk '{print $78}'` + iphen=`echo ${oi} | awk '{print $79}'` + iallom=`echo ${oi} | awk '{print $80}'` + ibigleaf=`echo ${oi} | awk '{print $81}'` + irepro=`echo ${oi} | awk '{print $82}'` #---------------------------------------------------------------------------------------# diff --git a/ED/Template/clean_scratch.sh b/ED/Template/clean_scratch.sh new file mode 100755 index 000000000..ee6606874 --- /dev/null +++ b/ED/Template/clean_scratch.sh @@ -0,0 +1,78 @@ +#!/bin/sh +myself=`whoami` + +#----- Check which queue we will clean. ---------------------------------------------------# +if [ 'x'${1} == 'x' ] +then + echo -n 'Which queue do you want to clean?' + read queue +else + queue=${1} +fi +#------------------------------------------------------------------------------------------# + + + +#------------------------------------------------------------------------------------------# +# Select the nodes to be deleted. # +#------------------------------------------------------------------------------------------# +case ${queue} in +moorcroft_6100a) + nodes="moorcroft01 moorcroft02 moorcroft03 moorcroft04" + ;; +moorcroft_6100b) + nodes="moorcroft05 moorcroft06 moorcroft07 moorcroft08 moorcroft09 + moorcroft10 moorcroft11 moorcroft12 moorcroft13 moorcroft14 + moorcroft15 moorcroft16 moorcroft17 moorcroft18 moorcroft19 + moorcroft20 moorcroft21 moorcroft22 moorcroft23 moorcroft24 + moorcroft25 moorcroft26 moorcroft27 moorcroft28 moorcroft29 + moorcroft30 moorcroft31 moorcroft32 moorcroft33 moorcroft34 + moorcroft35 moorcroft36 moorcroft37 moorcroft38 moorcroft39 + moorcroft40 moorcroft41 moorcroft42 moorcroft43 moorcroft44" + ;; +moorcroft2a) + nodes="hero4001 hero4002 hero4003 hero4004 hero4005 hero4006 + hero4007 hero4008 hero4009 hero4010 hero4011 hero4013" + ;; +moorcroft2b) + nodes="hero4014 hero4015 hero4016 hero4101 hero4102 hero4103 + hero4104 hero4105 hero4106 hero4107 hero4108" + ;; +moorcroft2c) + nodes="hero4109 hero4110 hero4111 hero4112 hero4113 hero4114 hero4115 hero4116" + ;; +wofsy) + nodes="wofsy011 wofsy012 wofsy013 wofsy014 wofsy021 wofsy022 wofsy023 wofsy024" + ;; +camd) + nodes="camd04 camd05 camd06 camd07 camd09 camd10 camd11 camd13" + ;; +unrestricted_parallel) + nodes="hero3102 hero3103 hero3104 hero3107 hero3108 hero3109 hero3110 + hero3111 hero3112 hero3113 hero3114 hero3115 hero3116 hero3201 + hero3202 hero3203 hero3204 hero3205 hero3206 hero3207 hero3208 + hero3209 hero3210 hero3211 hero3212 hero3213 hero3214 hero3215 + hero3216" + ;; +unrestricted_serial) + nodes="soph57 soph58 soph59 soph60 soph61 soph62 soph63 soph64" + ;; +*) + echo ' I cannot recognise queue '${queue}'...' + exit 39 + ;; +esac +#------------------------------------------------------------------------------------------# + + + +#------------------------------------------------------------------------------------------# +# Delete the files in all nodes that the queue uses. # +#------------------------------------------------------------------------------------------# +for node in ${nodes} +do + echo -n ' Deleting files from node '${node}'...' + ssh ${node} rm -fr /scratch/${myself} 1> /dev/null 2>&1 + echo 'Gone!' +done +#------------------------------------------------------------------------------------------# diff --git a/ED/Template/delall.sh b/ED/Template/delall.sh index 6941e9902..10571b1a0 100755 --- a/ED/Template/delall.sh +++ b/ED/Template/delall.sh @@ -1,7 +1,7 @@ #!/bin/sh here=`pwd` moi=`whoami` -diskthere='/n/scratch2/moorcroft_lab' +diskthere='/n/moorcroftfs2' lonlat=${here}'/joborder.txt' #----- Find the output path (both local and remote paths will be cleaned). ----------------# @@ -162,23 +162,29 @@ do atmco2=`echo ${oi} | awk '{print $57}'` thcrit=`echo ${oi} | awk '{print $58}'` smfire=`echo ${oi} | awk '{print $59}'` - isoilbc=`echo ${oi} | awk '{print $60}'` - imetrad=`echo ${oi} | awk '{print $61}'` - ibranch=`echo ${oi} | awk '{print $62}'` - icanrad=`echo ${oi} | awk '{print $63}'` - crown=`echo ${oi} | awk '{print $64}'` - ltransvis=`echo ${oi} | awk '{print $65}'` - lreflectvis=`echo ${oi} | awk '{print $66}'` - ltransnir=`echo ${oi} | awk '{print $67}'` - lreflectnir=`echo ${oi} | awk '{print $68}'` - orienttree=`echo ${oi} | awk '{print $69}'` - orientgrass=`echo ${oi} | awk '{print $70}'` - clumptree=`echo ${oi} | awk '{print $71}'` - clumpgrass=`echo ${oi} | awk '{print $72}'` - ivegtdyn=`echo ${oi} | awk '{print $73}'` - igndvap=`echo ${oi} | awk '{print $74}'` - iphen=`echo ${oi} | awk '{print $75}'` - iallom=`echo ${oi} | awk '{print $76}'` + ifire=`echo ${oi} | awk '{print $60}'` + fireparm=`echo ${oi} | awk '{print $61}'` + ipercol=`echo ${oi} | awk '{print $62}'` + isoilbc=`echo ${oi} | awk '{print $63}'` + runoff=`echo ${oi} | awk '{print $64}'` + imetrad=`echo ${oi} | awk '{print $65}'` + ibranch=`echo ${oi} | awk '{print $66}'` + icanrad=`echo ${oi} | awk '{print $67}'` + crown=`echo ${oi} | awk '{print $68}'` + ltransvis=`echo ${oi} | awk '{print $69}'` + lreflectvis=`echo ${oi} | awk '{print $70}'` + ltransnir=`echo ${oi} | awk '{print $71}'` + lreflectnir=`echo ${oi} | awk '{print $72}'` + orienttree=`echo ${oi} | awk '{print $73}'` + orientgrass=`echo ${oi} | awk '{print $74}'` + clumptree=`echo ${oi} | awk '{print $75}'` + clumpgrass=`echo ${oi} | awk '{print $76}'` + ivegtdyn=`echo ${oi} | awk '{print $77}'` + igndvap=`echo ${oi} | awk '{print $78}'` + iphen=`echo ${oi} | awk '{print $79}'` + iallom=`echo ${oi} | awk '{print $80}'` + ibigleaf=`echo ${oi} | awk '{print $81}'` + irepro=`echo ${oi} | awk '{print $82}'` #---------------------------------------------------------------------------------------# diff --git a/ED/Template/epost.sh b/ED/Template/epost.sh index 3f2661534..fe96a4e26 100755 --- a/ED/Template/epost.sh +++ b/ED/Template/epost.sh @@ -1,6 +1,6 @@ #!/bin/bash here=`pwd` # ! Main path -diskthere='/n/scratch2/moorcroft_lab' # ! Disk where the output files are +diskthere='/n/moorcroftfs2' # ! Disk where the output files are thisqueue='moorcroft' # ! Queue where jobs should be submitted lonlat=${here}'/joborder.txt' # ! File with the job instructions #----- Outroot is the main output directory. ----------------------------------------------# @@ -54,7 +54,9 @@ echo 'Number of polygons: '${npolys}'...' # - plot_photo.r - This creates plots from the detailed output for Farquhar-Leuning. # # - plot_rk4pc.r - This creates plots from the detailed output for Runge-Kutta. # # (patch- and cohort-level). # -# +# - plot_budget.r - This creates plots from the detailed budget for Runge-Kutta. # +# (patch-level only). # +# # # The following scripts should work too, but I haven't tested them. # # - plot_daily.r - This creates plots from the daily mean output. # # - plot_fast.r - This creates plots from the analysis files. # @@ -140,23 +142,29 @@ do atmco2=`echo ${oi} | awk '{print $57}'` thcrit=`echo ${oi} | awk '{print $58}'` smfire=`echo ${oi} | awk '{print $59}'` - isoilbc=`echo ${oi} | awk '{print $60}'` - imetrad=`echo ${oi} | awk '{print $61}'` - ibranch=`echo ${oi} | awk '{print $62}'` - icanrad=`echo ${oi} | awk '{print $63}'` - crown=`echo ${oi} | awk '{print $64}'` - ltransvis=`echo ${oi} | awk '{print $65}'` - lreflectvis=`echo ${oi} | awk '{print $66}'` - ltransnir=`echo ${oi} | awk '{print $67}'` - lreflectnir=`echo ${oi} | awk '{print $68}'` - orienttree=`echo ${oi} | awk '{print $69}'` - orientgrass=`echo ${oi} | awk '{print $70}'` - clumptree=`echo ${oi} | awk '{print $71}'` - clumpgrass=`echo ${oi} | awk '{print $72}'` - ivegtdyn=`echo ${oi} | awk '{print $73}'` - igndvap=`echo ${oi} | awk '{print $74}'` - iphen=`echo ${oi} | awk '{print $75}'` - iallom=`echo ${oi} | awk '{print $76}'` + ifire=`echo ${oi} | awk '{print $60}'` + fireparm=`echo ${oi} | awk '{print $61}'` + ipercol=`echo ${oi} | awk '{print $62}'` + isoilbc=`echo ${oi} | awk '{print $63}'` + runoff=`echo ${oi} | awk '{print $64}'` + imetrad=`echo ${oi} | awk '{print $65}'` + ibranch=`echo ${oi} | awk '{print $66}'` + icanrad=`echo ${oi} | awk '{print $67}'` + crown=`echo ${oi} | awk '{print $68}'` + ltransvis=`echo ${oi} | awk '{print $69}'` + lreflectvis=`echo ${oi} | awk '{print $70}'` + ltransnir=`echo ${oi} | awk '{print $71}'` + lreflectnir=`echo ${oi} | awk '{print $72}'` + orienttree=`echo ${oi} | awk '{print $73}'` + orientgrass=`echo ${oi} | awk '{print $74}'` + clumptree=`echo ${oi} | awk '{print $75}'` + clumpgrass=`echo ${oi} | awk '{print $76}'` + ivegtdyn=`echo ${oi} | awk '{print $77}'` + igndvap=`echo ${oi} | awk '{print $78}'` + iphen=`echo ${oi} | awk '{print $79}'` + iallom=`echo ${oi} | awk '{print $80}'` + ibigleaf=`echo ${oi} | awk '{print $81}'` + irepro=`echo ${oi} | awk '{print $82}'` #---------------------------------------------------------------------------------------# @@ -189,6 +197,13 @@ do epostlsf='pmon_epost.lsf' epostjob='eb-pmon-'${polyiata} ;; + plot_budget.r) + thisyeara=${yeara} + let thisdatea=${datea}+1 + epostout='pbdg_epost.out' + epostlsf='pbdg_epost.lsf' + epostjob='eb-pbdg-'${polyiata} + ;; plot_rk4.r) thisyeara=${yeara} let thisdatea=${datea}+1 diff --git a/ED/Template/joborder.txt b/ED/Template/joborder.txt index 311b06feb..c339d1c35 100644 --- a/ED/Template/joborder.txt +++ b/ED/Template/joborder.txt @@ -1,96 +1,108 @@ --------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- -POLYGON_NAME IATA LONGITUDE LATITUDE YEARA MONTHA DAYA TIMEA YEARZ MONTHZ DAYZ TIMEZ ISOIL NTEXT SAND CLAY DEPTH COLOUR SLZRES QUEUE MET_DRIVER DTLSM VMFACT_C3 VMFACT_C4 MPHOTO_TRC3 MPHOTO_TEC3 MPHOTO_C4 BPHOTO_BLC3 BPHOTO_NLC3 BPHOTO_C4 KW_GRASS KW_TREE GAMMA_C3 GAMMA_C4 D0_GRASS D0_TREE ALPHA_C3 ALPHA_C4 KLOWCO2 RRFFACT GROWTHRESP LWIDTH_GRASS LWIDTH_BLTREE LWIDTH_NLTREE Q10_C3 Q10_C4 H2O_LIMIT ISFCLYRM ICANTURB UBMIN UGBMIN USTMIN GAMM GAMH TPRANDTL RIBMAX ATMCO2 THCRIT SM_FIRE ISOILBC IMETRAD IBRANCH ICANRAD CROWN_MOD LTRANS_VIS LREFLECT_VIS LTRANS_NIR LREFLECT_NIR ORIENT_TREE ORIENT_GRASS CLUMP_TREE CLUMP_GRASS IVEGTDYN IGNDVAP IPHEN IALLOM --------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- -harvard hvd -72.170 42.540 1199 05 01 0000 1700 01 01 0000 2 2 -1.0000 -1.000 E 2 0 camd Harvard 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 1 2 -manaus_km34 m34 -60.209 -2.609 1200 01 01 0000 1700 01 01 0000 2 11 0.2000 0.680 H 2 0 camd Manaus_KM34 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -caxiuana cax -51.458 -1.720 1200 01 01 0000 1700 01 01 0000 2 16 0.3800 0.440 D 2 0 camd Caxiuana 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -santarem_km67 s67 -54.959 -2.857 1200 01 01 0000 1700 01 01 0000 2 15 0.0200 0.900 H 2 0 camd Santarem_KM67 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -santarem_km83 s83 -54.971 -3.018 1200 01 01 0000 1700 01 01 0000 2 16 0.3900 0.590 H 2 0 camd Santarem_KM83 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -rebio_jaru rja -61.931 -10.083 1200 01 01 0000 1700 01 01 0000 2 2 0.8000 0.100 D 2 0 camd Reserva_Jaru 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -pedegigante pdg -47.650 -21.619 1200 01 01 0000 1700 01 01 0000 2 2 0.8500 0.030 F 2 0 camd Reserva_Pe-de-Gigante 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -paracou gyf -52.912 5.282 1200 01 01 0000 1700 01 01 0000 2 6 0.5620 0.345 E 2 0 camd Guyaflux 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -bananal ban -50.159 -9.824 1200 01 01 0000 1700 01 01 0000 2 9 0.2400 0.370 C 2 0 camd Bananal_Island 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -la_lorena lor -69.991 -3.056 1200 01 01 0000 1700 01 01 0000 2 9 0.3800 0.310 A 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -el_zafire zar -69.902 -4.007 1200 01 01 0000 1700 01 01 0000 2 2 0.7475 0.006 B 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -allpahuayo alp -73.437 -3.953 1200 01 01 0000 1700 01 01 0000 2 1 0.9370 0.026 D 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -tambopata tam -69.271 -12.830 1200 01 01 0000 1700 01 01 0000 2 11 0.4000 0.430 B 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -fazendans fns -62.357 -10.762 1200 01 01 0000 1700 01 01 0000 2 2 0.8000 0.100 G 2 0 camd Fazenda_NS 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -santarem_km77 s77 -54.537 -3.012 1200 01 01 0000 1700 01 01 0000 2 11 0.1800 0.800 H 2 0 camd Santarem_KM77 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -kenia qea -62.730 -16.010 1200 01 01 0000 1700 01 01 0000 2 3 0.7600 0.160 D 2 0 camd Santarem_KM77 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -barro_colorado bci -79.850 9.160 1200 01 01 0000 1700 01 01 0000 2 17 0.2000 0.420 D 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -cardoso czi -47.957 -25.096 1200 01 01 0000 1700 01 01 0000 2 1 0.9500 0.010 C 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -la_selva lzv -84.010 10.430 1200 01 01 0000 1700 01 01 0000 2 6 0.5700 0.290 F 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -la_planada lpn -77.994 1.116 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -sinop ops -55.325 -11.412 1200 01 01 0000 1700 01 01 0000 2 2 0.8400 0.120 E 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -yasuni ysn -76.396 -0.686 1200 01 01 0000 1700 01 01 0000 2 4 0.2590 0.255 F 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -alta_floresta afl -56.100 -9.867 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -angra_dos_reis aei -44.300 -22.970 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -araguaiana ayx -51.810 -15.710 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -araracuara arc -72.398 -0.601 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -asuncion asu -57.560 -25.300 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -belo_horizonte cnf -43.950 -19.850 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -belem bel -48.480 -1.380 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -blumenau bnu -49.060 -26.920 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -boa_vista bvb -60.610 2.920 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -bogota bog -74.100 4.650 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -brasilia bsb -47.910 -15.860 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -cabo_frio cfb -42.070 -22.920 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -cajazeiras cjz -38.570 -6.900 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -calabozo clz -67.420 8.920 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -canarana qnr -52.250 -13.560 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -carajas cks -50.722 -5.786 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -chaiten wch -72.500 -42.500 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -cochabamba cbb -66.170 -17.420 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -cuiaba cgb -56.100 -15.600 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -curitiba cwb -49.230 -25.410 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -diamantino dmt -56.620 -14.370 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -dourados dou -54.810 -22.220 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -el_triunfo etf -67.000 -13.500 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -erechim erm -52.240 -27.610 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -eunapolis enp -39.580 -16.330 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -fortaleza for -38.530 -3.780 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -iguape igp -47.590 -24.630 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -imperatriz imp -47.460 -5.530 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -iquique iqq -69.970 -20.240 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -itabaiana ibn -37.420 -10.680 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -itapeva ipv -48.880 -23.980 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -jacareacanga jcr -57.777 -6.233 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -jiparana jpr -61.980 -10.860 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -joao_pessoa jpa -34.910 -7.100 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -la_esmeralda lfe -65.540 3.170 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -labrea lbr -64.770 -7.280 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -lencois lec -41.350 -12.480 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -macapa mcp -51.090 0.330 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -malalcahuello zmh -71.580 -38.470 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -manaus mao -60.020 -3.110 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -manicore mnx -61.280 -5.820 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -maringa mgf -52.010 -23.470 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -montes_claros moc -43.820 -16.710 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -neuquen nqn -68.000 -39.000 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -oeiras oei -42.160 -7.020 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -palmas pmw -48.360 -10.290 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -paramaribo pbm -55.150 5.830 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -petrolina pnz -40.510 -9.390 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -porto_de_moz ptq -52.236 -1.741 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -pucallpa pcl -74.570 -8.380 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -puerto_suarez psz -58.090 -18.580 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -quibdo uib -76.640 5.690 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -recife rec -34.910 -8.070 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -redencao rdc -49.980 -8.030 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -ribeirao_preto rao -47.780 -21.140 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -rio_branco rbr -67.890 -9.870 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -salta sla -65.483 -24.850 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -san_pedro zpe -54.110 -26.630 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -sao_felix_araguaia sxo -50.690 -11.630 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -sao_felix_xingu sxx -51.950 -6.640 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -sao_luis slz -44.236 -2.586 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -sao_gabriel sjl -66.980 -0.140 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -santarem stm -54.959 -2.857 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -tarauaca trq -70.781 -8.157 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -tefe tff -64.720 -3.380 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -teresina the -42.800 -5.090 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -tirios obi -55.940 2.220 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -vina_del_mar kna -71.480 -32.950 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -vilhena bvh -60.100 -12.730 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -vitoria vix -40.390 -20.310 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 -xingu xgu -52.636 -9.692 1200 01 01 0000 1700 01 01 0000 1 1 -1.0000 -1.000 H 2 0 camd Sheffield 240 1.25 1.00 9.0 7.2 5.0 10000. 1000. 8000. 300. 300. 0.015 0.036 0.015 0.015 0.080 0.053 4000. 1.000 0.333 0.05 0.10 0.05 2.2 2.2 2 3 4 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.20 0.07 1 2 1 0 1 0.050 0.100 0.270 0.540 0.150 -0.150 1.000 1.000 1 0 2 2 +---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- +POLYGON_NAME IATA LONGITUDE LATITUDE YEARA MONTHA DAYA TIMEA YEARZ MONTHZ DAYZ TIMEZ ISOIL NTEXT SAND CLAY DEPTH COLOUR SLZRES QUEUE MET_DRIVER DTLSM VMFACT_C3 VMFACT_C4 MPHOTO_TRC3 MPHOTO_TEC3 MPHOTO_C4 BPHOTO_BLC3 BPHOTO_NLC3 BPHOTO_C4 KW_GRASS KW_TREE GAMMA_C3 GAMMA_C4 D0_GRASS D0_TREE ALPHA_C3 ALPHA_C4 KLOWCO2 RRFFACT GROWTHRESP LWIDTH_GRASS LWIDTH_BLTREE LWIDTH_NLTREE Q10_C3 Q10_C4 H2O_LIMIT ISFCLYRM ICANTURB UBMIN UGBMIN USTMIN GAMM GAMH TPRANDTL RIBMAX ATMCO2 THCRIT SM_FIRE IFIRE FIRE_PARM IPERCOL ISOILBC RUNOFF_TIME IMETRAD IBRANCH ICANRAD CROWN_MOD LTRANS_VIS LREFLECT_VIS LTRANS_NIR LREFLECT_NIR ORIENT_TREE ORIENT_GRASS CLUMP_TREE CLUMP_GRASS IVEGTDYN IGNDVAP IPHEN IALLOM IBIGLEAF IREPRO +---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- +harvard hvd -72.170 42.540 1199 05 01 0000 1700 01 01 0000 2 2 -1.000 -1.000 E 2 0 moorcroft_6100b Harvard 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +tonzi tzi -120.894 38.427 1199 05 01 0000 1700 01 01 0000 2 5 0.447 0.191 D 2 0 moorcroft_6100b Tonzi 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +manaus_km34 m34 -60.209 -2.609 1200 01 01 0000 1700 01 01 0000 2 11 0.200 0.680 H 2 0 moorcroft_6100b Manaus_KM34 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +caxiuana cax -51.458 -1.720 1200 01 01 0000 1700 01 01 0000 2 16 0.380 0.440 D 2 0 moorcroft_6100b Caxiuana 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +santarem_km66 s66 -54.959 -2.857 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 H 2 0 moorcroft_6100b Santarem_KM66 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +santarem_km67 s67 -54.959 -2.857 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 H 2 0 moorcroft_6100b Santarem_KM67 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +santarem_km83 s83 -54.971 -3.018 1200 01 01 0000 1700 01 01 0000 2 16 0.390 0.590 H 2 0 moorcroft_6100b Santarem_KM83 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +rebio_jaru rja -61.931 -10.083 1200 01 01 0000 1700 01 01 0000 2 2 0.800 0.100 D 2 0 moorcroft_6100b Reserva_Jaru 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +pedegigante pdg -47.650 -21.619 1200 01 01 0000 1700 01 01 0000 2 2 0.850 0.030 F 2 0 moorcroft_6100b Reserva_Pe-de-Gigante 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +paracou gyf -52.912 5.282 1200 01 01 0000 1700 01 01 0000 2 6 0.562 0.345 E 2 0 moorcroft_6100b Guyaflux 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +bananal ban -50.159 -9.824 1200 01 01 0000 1700 01 01 0000 2 9 0.240 0.370 C 2 0 moorcroft_6100b Bananal_Island 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +la_lorena lor -69.991 -3.056 1200 01 01 0000 1700 01 01 0000 2 9 0.380 0.310 A 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +el_zafire zar -69.902 -4.007 1200 01 01 0000 1700 01 01 0000 2 2 0.748 0.006 B 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +allpahuayo alp -73.437 -3.953 1200 01 01 0000 1700 01 01 0000 2 1 0.937 0.026 D 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +tambopata tam -69.271 -12.830 1200 01 01 0000 1700 01 01 0000 2 11 0.400 0.430 B 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +fazendans fns -62.357 -10.762 1200 01 01 0000 1700 01 01 0000 2 2 0.800 0.100 G 2 0 moorcroft_6100b Fazenda_NS 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +santarem_km77 s77 -54.537 -3.012 1200 01 01 0000 1700 01 01 0000 2 11 0.180 0.800 H 2 0 moorcroft_6100b Santarem_KM77 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +kenia qea -62.730 -16.010 1200 01 01 0000 1700 01 01 0000 2 3 0.760 0.160 D 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +barro_colorado bci -79.850 9.160 1200 01 01 0000 1700 01 01 0000 2 17 0.200 0.420 D 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +cardoso czi -48.010 -25.096 1200 01 01 0000 1700 01 01 0000 2 1 0.950 0.010 C 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +la_selva lzv -84.010 10.430 1200 01 01 0000 1700 01 01 0000 2 6 0.570 0.290 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +la_planada lpn -77.994 1.116 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 H 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +sinop ops -55.325 -11.412 1200 01 01 0000 1700 01 01 0000 2 2 0.840 0.120 E 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +yasuni ysn -76.396 -0.686 1200 01 01 0000 1700 01 01 0000 2 4 0.259 0.255 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +alta_floresta afl -56.100 -9.867 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +angra_dos_reis aei -44.300 -22.970 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +araguaiana ayx -51.810 -15.710 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +araracuara arc -72.398 -0.601 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +asuncion asu -57.560 -25.300 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +belo_horizonte cnf -43.950 -19.850 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +belem bel -48.480 -1.380 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +blumenau bnu -49.060 -26.920 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +boa_vista bvb -60.610 2.920 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +bogota bog -74.100 4.650 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +brasilia bsb -47.910 -15.860 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +cabo_frio cfb -42.070 -22.490 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +cajazeiras cjz -38.570 -6.900 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +calabozo clz -67.420 8.920 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +canarana qnr -52.250 -13.560 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +carajas cks -50.722 -5.786 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +chaiten wch -72.500 -42.500 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +ciudad_guayana cgu -62.762 8.289 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +cochabamba cbb -66.170 -17.420 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +cuiaba cgb -56.100 -15.600 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +curitiba cwb -49.230 -25.410 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +diamantino dmt -56.620 -14.370 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +dourados dou -54.810 -22.220 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +el_triunfo etf -67.000 -13.500 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +erechim erm -52.240 -27.610 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +eunapolis enp -39.580 -16.330 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +fortaleza for -38.530 -3.780 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +iguape igp -47.590 -24.630 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +imperatriz imp -47.460 -5.530 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +iquique iqq -69.970 -20.240 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +itabaiana ibn -37.420 -10.680 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +itapeva ipv -48.880 -23.980 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +jacareacanga jcr -57.777 -6.233 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +jiparana jpr -61.980 -10.860 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +joao_pessoa jpa -34.910 -7.100 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +la_esmeralda lfe -65.540 3.170 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +labrea lbr -64.770 -7.280 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +lencois lec -41.350 -12.480 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +linden lyd -58.302 6.015 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +llochegua llo -73.908 -12.410 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +macapa mcp -51.090 0.330 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +malalcahuello zmh -71.580 -38.470 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +manaus mao -60.020 -3.110 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +manicore mnx -61.280 -5.820 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +maracarume zme -45.954 -2.041 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +maringa mgf -52.010 -23.470 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +mariscal_estagarribia esg -60.624 -22.043 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +montes_claros moc -43.820 -16.710 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +neuquen nqn -68.000 -39.000 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +oeiras oei -42.160 -7.020 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +palmas pmw -48.360 -10.290 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +paramaribo pbm -55.150 5.830 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +petrolina pnz -40.510 -9.390 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +piura piu -80.617 -5.207 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +porto_de_moz ptq -52.236 -1.741 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +pucallpa pcl -74.570 -8.380 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +puerto_suarez psz -58.090 -18.580 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +quibdo uib -76.640 5.690 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +recife rec -34.910 -8.070 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +redencao rdc -49.980 -8.030 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +ribeirao_preto rao -47.780 -21.140 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +rio_branco rbr -67.890 -9.870 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +riohacha rch -72.926 11.240 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +salta sla -65.483 -24.850 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +san_pedro zpe -54.110 -26.630 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +sao_felix_araguaia sxo -50.690 -11.630 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +sao_felix_xingu sxx -51.950 -6.640 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +sao_luis slz -44.236 -2.586 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +sao_gabriel sjl -66.980 -0.140 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +santa_fe sfn -60.809 -31.712 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +santarem stm -54.959 -2.857 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +sobral qbx -39.990 -4.010 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +tarauaca trq -70.781 -8.157 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +tefe tff -64.720 -3.380 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +teresina the -42.800 -5.090 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +tirios obi -55.940 2.220 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +tolhuin tqh -67.222 -54.502 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +vina_del_mar kna -71.480 -32.950 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +vilhena bvh -60.100 -12.730 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +vitoria vix -40.390 -20.310 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 +xingu xgu -52.636 -9.692 1200 01 01 0000 1700 01 01 0000 1 1 -1.000 -1.000 F 2 0 moorcroft_6100b Sheffield 600. 1.00 1.00 9.0 7.2 5.2 10000. 1000. 10000. 600. 450. 0.015 0.040 0.016 0.016 0.080 0.055 4000. 1.000 0.333 0.05 0.10 0.05 2.4 2.4 2 3 2 0.65 0.25 0.05 13.0 13.0 0.74 0.50 378. -1.10 -1.40 2 1.0 0 1 3600. 2 1 0 1 0.050 0.100 0.270 0.540 0.100 -0.100 0.800 1.000 1 0 2 2 0 2 diff --git a/ED/Template/nc_check_run.sh b/ED/Template/nc_check_run.sh index b427e0753..7f53de658 100755 --- a/ED/Template/nc_check_run.sh +++ b/ED/Template/nc_check_run.sh @@ -82,23 +82,29 @@ do atmco2=`echo ${oi} | awk '{print $57}'` thcrit=`echo ${oi} | awk '{print $58}'` smfire=`echo ${oi} | awk '{print $59}'` - isoilbc=`echo ${oi} | awk '{print $60}'` - imetrad=`echo ${oi} | awk '{print $61}'` - ibranch=`echo ${oi} | awk '{print $62}'` - icanrad=`echo ${oi} | awk '{print $63}'` - crown=`echo ${oi} | awk '{print $64}'` - ltransvis=`echo ${oi} | awk '{print $65}'` - lreflectvis=`echo ${oi} | awk '{print $66}'` - ltransnir=`echo ${oi} | awk '{print $67}'` - lreflectnir=`echo ${oi} | awk '{print $68}'` - orienttree=`echo ${oi} | awk '{print $69}'` - orientgrass=`echo ${oi} | awk '{print $70}'` - clumptree=`echo ${oi} | awk '{print $71}'` - clumpgrass=`echo ${oi} | awk '{print $72}'` - ivegtdyn=`echo ${oi} | awk '{print $73}'` - igndvap=`echo ${oi} | awk '{print $74}'` - iphen=`echo ${oi} | awk '{print $75}'` - iallom=`echo ${oi} | awk '{print $76}'` + ifire=`echo ${oi} | awk '{print $60}'` + fireparm=`echo ${oi} | awk '{print $61}'` + ipercol=`echo ${oi} | awk '{print $62}'` + isoilbc=`echo ${oi} | awk '{print $63}'` + runoff=`echo ${oi} | awk '{print $64}'` + imetrad=`echo ${oi} | awk '{print $65}'` + ibranch=`echo ${oi} | awk '{print $66}'` + icanrad=`echo ${oi} | awk '{print $67}'` + crown=`echo ${oi} | awk '{print $68}'` + ltransvis=`echo ${oi} | awk '{print $69}'` + lreflectvis=`echo ${oi} | awk '{print $70}'` + ltransnir=`echo ${oi} | awk '{print $71}'` + lreflectnir=`echo ${oi} | awk '{print $72}'` + orienttree=`echo ${oi} | awk '{print $73}'` + orientgrass=`echo ${oi} | awk '{print $74}'` + clumptree=`echo ${oi} | awk '{print $75}'` + clumpgrass=`echo ${oi} | awk '{print $76}'` + ivegtdyn=`echo ${oi} | awk '{print $77}'` + igndvap=`echo ${oi} | awk '{print $78}'` + iphen=`echo ${oi} | awk '{print $79}'` + iallom=`echo ${oi} | awk '{print $80}'` + ibigleaf=`echo ${oi} | awk '{print $81}'` + irepro=`echo ${oi} | awk '{print $82}'` #---------------------------------------------------------------------------------------# diff --git a/ED/Template/nc_spawn.sh b/ED/Template/nc_spawn.sh index 1ebe7a400..658f54c1d 100755 --- a/ED/Template/nc_spawn.sh +++ b/ED/Template/nc_spawn.sh @@ -97,23 +97,29 @@ do atmco2=`echo ${oi} | awk '{print $57}'` thcrit=`echo ${oi} | awk '{print $58}'` smfire=`echo ${oi} | awk '{print $59}'` - isoilbc=`echo ${oi} | awk '{print $60}'` - imetrad=`echo ${oi} | awk '{print $61}'` - ibranch=`echo ${oi} | awk '{print $62}'` - icanrad=`echo ${oi} | awk '{print $63}'` - crown=`echo ${oi} | awk '{print $64}'` - ltransvis=`echo ${oi} | awk '{print $65}'` - lreflectvis=`echo ${oi} | awk '{print $66}'` - ltransnir=`echo ${oi} | awk '{print $67}'` - lreflectnir=`echo ${oi} | awk '{print $68}'` - orienttree=`echo ${oi} | awk '{print $69}'` - orientgrass=`echo ${oi} | awk '{print $70}'` - clumptree=`echo ${oi} | awk '{print $71}'` - clumpgrass=`echo ${oi} | awk '{print $72}'` - ivegtdyn=`echo ${oi} | awk '{print $73}'` - igndvap=`echo ${oi} | awk '{print $74}'` - iphen=`echo ${oi} | awk '{print $75}'` - iallom=`echo ${oi} | awk '{print $76}'` + ifire=`echo ${oi} | awk '{print $60}'` + fireparm=`echo ${oi} | awk '{print $61}'` + ipercol=`echo ${oi} | awk '{print $62}'` + isoilbc=`echo ${oi} | awk '{print $63}'` + runoff=`echo ${oi} | awk '{print $64}'` + imetrad=`echo ${oi} | awk '{print $65}'` + ibranch=`echo ${oi} | awk '{print $66}'` + icanrad=`echo ${oi} | awk '{print $67}'` + crown=`echo ${oi} | awk '{print $68}'` + ltransvis=`echo ${oi} | awk '{print $69}'` + lreflectvis=`echo ${oi} | awk '{print $70}'` + ltransnir=`echo ${oi} | awk '{print $71}'` + lreflectnir=`echo ${oi} | awk '{print $72}'` + orienttree=`echo ${oi} | awk '{print $73}'` + orientgrass=`echo ${oi} | awk '{print $74}'` + clumptree=`echo ${oi} | awk '{print $75}'` + clumpgrass=`echo ${oi} | awk '{print $76}'` + ivegtdyn=`echo ${oi} | awk '{print $77}'` + igndvap=`echo ${oi} | awk '{print $78}'` + iphen=`echo ${oi} | awk '{print $79}'` + iallom=`echo ${oi} | awk '{print $80}'` + ibigleaf=`echo ${oi} | awk '{print $81}'` + irepro=`echo ${oi} | awk '{print $82}'` #---------------------------------------------------------------------------------------# diff --git a/ED/Template/nc_submitter.sh b/ED/Template/nc_submitter.sh index 518f82a68..cf137572b 100755 --- a/ED/Template/nc_submitter.sh +++ b/ED/Template/nc_submitter.sh @@ -81,23 +81,29 @@ do atmco2=`echo ${oi} | awk '{print $57}'` thcrit=`echo ${oi} | awk '{print $58}'` smfire=`echo ${oi} | awk '{print $59}'` - isoilbc=`echo ${oi} | awk '{print $60}'` - imetrad=`echo ${oi} | awk '{print $61}'` - ibranch=`echo ${oi} | awk '{print $62}'` - icanrad=`echo ${oi} | awk '{print $63}'` - crown=`echo ${oi} | awk '{print $64}'` - ltransvis=`echo ${oi} | awk '{print $65}'` - lreflectvis=`echo ${oi} | awk '{print $66}'` - ltransnir=`echo ${oi} | awk '{print $67}'` - lreflectnir=`echo ${oi} | awk '{print $68}'` - orienttree=`echo ${oi} | awk '{print $69}'` - orientgrass=`echo ${oi} | awk '{print $70}'` - clumptree=`echo ${oi} | awk '{print $71}'` - clumpgrass=`echo ${oi} | awk '{print $72}'` - ivegtdyn=`echo ${oi} | awk '{print $73}'` - igndvap=`echo ${oi} | awk '{print $74}'` - iphen=`echo ${oi} | awk '{print $75}'` - iallom=`echo ${oi} | awk '{print $76}'` + ifire=`echo ${oi} | awk '{print $60}'` + fireparm=`echo ${oi} | awk '{print $61}'` + ipercol=`echo ${oi} | awk '{print $62}'` + isoilbc=`echo ${oi} | awk '{print $63}'` + runoff=`echo ${oi} | awk '{print $64}'` + imetrad=`echo ${oi} | awk '{print $65}'` + ibranch=`echo ${oi} | awk '{print $66}'` + icanrad=`echo ${oi} | awk '{print $67}'` + crown=`echo ${oi} | awk '{print $68}'` + ltransvis=`echo ${oi} | awk '{print $69}'` + lreflectvis=`echo ${oi} | awk '{print $70}'` + ltransnir=`echo ${oi} | awk '{print $71}'` + lreflectnir=`echo ${oi} | awk '{print $72}'` + orienttree=`echo ${oi} | awk '{print $73}'` + orientgrass=`echo ${oi} | awk '{print $74}'` + clumptree=`echo ${oi} | awk '{print $75}'` + clumpgrass=`echo ${oi} | awk '{print $76}'` + ivegtdyn=`echo ${oi} | awk '{print $77}'` + igndvap=`echo ${oi} | awk '{print $78}'` + iphen=`echo ${oi} | awk '{print $79}'` + iallom=`echo ${oi} | awk '{print $80}'` + ibigleaf=`echo ${oi} | awk '{print $81}'` + irepro=`echo ${oi} | awk '{print $82}'` #---------------------------------------------------------------------------------------# diff --git a/ED/Template/reset.sh b/ED/Template/reset.sh index b7e67eb79..d00249191 100755 --- a/ED/Template/reset.sh +++ b/ED/Template/reset.sh @@ -1,7 +1,7 @@ #!/bin/sh here=`pwd` moi=`whoami` -diskthere='/n/scratch2/moorcroft_lab' +diskthere='/n/moorcroftfs2' lonlat=${here}'/joborder.txt' desc=`basename ${here}` @@ -149,23 +149,29 @@ do atmco2=`echo ${oi} | awk '{print $57}'` thcrit=`echo ${oi} | awk '{print $58}'` smfire=`echo ${oi} | awk '{print $59}'` - isoilbc=`echo ${oi} | awk '{print $60}'` - imetrad=`echo ${oi} | awk '{print $61}'` - ibranch=`echo ${oi} | awk '{print $62}'` - icanrad=`echo ${oi} | awk '{print $63}'` - crown=`echo ${oi} | awk '{print $64}'` - ltransvis=`echo ${oi} | awk '{print $65}'` - lreflectvis=`echo ${oi} | awk '{print $66}'` - ltransnir=`echo ${oi} | awk '{print $67}'` - lreflectnir=`echo ${oi} | awk '{print $68}'` - orienttree=`echo ${oi} | awk '{print $69}'` - orientgrass=`echo ${oi} | awk '{print $70}'` - clumptree=`echo ${oi} | awk '{print $71}'` - clumpgrass=`echo ${oi} | awk '{print $72}'` - ivegtdyn=`echo ${oi} | awk '{print $73}'` - igndvap=`echo ${oi} | awk '{print $74}'` - iphen=`echo ${oi} | awk '{print $75}'` - iallom=`echo ${oi} | awk '{print $76}'` + ifire=`echo ${oi} | awk '{print $60}'` + fireparm=`echo ${oi} | awk '{print $61}'` + ipercol=`echo ${oi} | awk '{print $62}'` + isoilbc=`echo ${oi} | awk '{print $63}'` + runoff=`echo ${oi} | awk '{print $64}'` + imetrad=`echo ${oi} | awk '{print $65}'` + ibranch=`echo ${oi} | awk '{print $66}'` + icanrad=`echo ${oi} | awk '{print $67}'` + crown=`echo ${oi} | awk '{print $68}'` + ltransvis=`echo ${oi} | awk '{print $69}'` + lreflectvis=`echo ${oi} | awk '{print $70}'` + ltransnir=`echo ${oi} | awk '{print $71}'` + lreflectnir=`echo ${oi} | awk '{print $72}'` + orienttree=`echo ${oi} | awk '{print $73}'` + orientgrass=`echo ${oi} | awk '{print $74}'` + clumptree=`echo ${oi} | awk '{print $75}'` + clumpgrass=`echo ${oi} | awk '{print $76}'` + ivegtdyn=`echo ${oi} | awk '{print $77}'` + igndvap=`echo ${oi} | awk '{print $78}'` + iphen=`echo ${oi} | awk '{print $79}'` + iallom=`echo ${oi} | awk '{print $80}'` + ibigleaf=`echo ${oi} | awk '{print $81}'` + irepro=`echo ${oi} | awk '{print $82}'` #---------------------------------------------------------------------------------------# bkill -J ${desc}-${polyname} -q ${queue} @@ -255,23 +261,29 @@ do atmco2=`echo ${oi} | awk '{print $57}'` thcrit=`echo ${oi} | awk '{print $58}'` smfire=`echo ${oi} | awk '{print $59}'` - isoilbc=`echo ${oi} | awk '{print $60}'` - imetrad=`echo ${oi} | awk '{print $61}'` - ibranch=`echo ${oi} | awk '{print $62}'` - icanrad=`echo ${oi} | awk '{print $63}'` - crown=`echo ${oi} | awk '{print $64}'` - ltransvis=`echo ${oi} | awk '{print $65}'` - lreflectvis=`echo ${oi} | awk '{print $66}'` - ltransnir=`echo ${oi} | awk '{print $67}'` - lreflectnir=`echo ${oi} | awk '{print $68}'` - orienttree=`echo ${oi} | awk '{print $69}'` - orientgrass=`echo ${oi} | awk '{print $70}'` - clumptree=`echo ${oi} | awk '{print $71}'` - clumpgrass=`echo ${oi} | awk '{print $72}'` - ivegtdyn=`echo ${oi} | awk '{print $73}'` - igndvap=`echo ${oi} | awk '{print $74}'` - iphen=`echo ${oi} | awk '{print $75}'` - iallom=`echo ${oi} | awk '{print $76}'` + ifire=`echo ${oi} | awk '{print $60}'` + fireparm=`echo ${oi} | awk '{print $61}'` + ipercol=`echo ${oi} | awk '{print $62}'` + isoilbc=`echo ${oi} | awk '{print $63}'` + runoff=`echo ${oi} | awk '{print $64}'` + imetrad=`echo ${oi} | awk '{print $65}'` + ibranch=`echo ${oi} | awk '{print $66}'` + icanrad=`echo ${oi} | awk '{print $67}'` + crown=`echo ${oi} | awk '{print $68}'` + ltransvis=`echo ${oi} | awk '{print $69}'` + lreflectvis=`echo ${oi} | awk '{print $70}'` + ltransnir=`echo ${oi} | awk '{print $71}'` + lreflectnir=`echo ${oi} | awk '{print $72}'` + orienttree=`echo ${oi} | awk '{print $73}'` + orientgrass=`echo ${oi} | awk '{print $74}'` + clumptree=`echo ${oi} | awk '{print $75}'` + clumpgrass=`echo ${oi} | awk '{print $76}'` + ivegtdyn=`echo ${oi} | awk '{print $77}'` + igndvap=`echo ${oi} | awk '{print $78}'` + iphen=`echo ${oi} | awk '{print $79}'` + iallom=`echo ${oi} | awk '{print $80}'` + ibigleaf=`echo ${oi} | awk '{print $81}'` + irepro=`echo ${oi} | awk '{print $82}'` #---------------------------------------------------------------------------------------# diff --git a/ED/Template/spawn_poly.sh b/ED/Template/spawn_poly.sh index c837615fb..6578903c5 100755 --- a/ED/Template/spawn_poly.sh +++ b/ED/Template/spawn_poly.sh @@ -17,7 +17,7 @@ lonlat=${here}'/joborder.txt' #----- Should the output be in a disk other than the one set in "here"? -------------------# outthere='y' #----- Disk name (usually just the path until right before your own directory). -----------# -diskthere='/n/scratch2/moorcroft_lab' +diskthere='/n/moorcroftfs2' #----- This is the default path with the met driver. --------------------------------------# sitemetdef='/n/moorcroft_data/mlongo/data/ed2_data/site_met_driver' #----- This is the header with the Sheffield data. ----------------------------------------# @@ -32,7 +32,7 @@ copy2scratch='y' # In case we should copy, this is the source where the data is organised to go. This # # will override sitemetdef and pdroughtpath. # #------------------------------------------------------------------------------------------# -packdatasrc='/n/data/moorcroft_lab/mlongo/stripe_1M_35' +packdatasrc='/n/moorcroft_data/mlongo/data/2scratch' #------------------------------------------------------------------------------------------# # History run variables. # @@ -92,9 +92,9 @@ execname='ed_2.1-opt' #----- Set the main path for the site, pseudo drought and Sheffield met drivers. ----------# if [ ${copy2scratch} == 'y' -o ${copy2scratch} == 'Y' ] then - sitemet='/scratch/'${moi}'/met_driver/site_met_driver' - pdroughtpath='/scratch/'${moi}'/met_driver/pseudo_drought' - shefpath='/scratch/'${moi}'/met_driver/sheffield' + sitemet='/scratch/ed2_data/met_driver/site_met_driver' + pdroughtpath='/scratch/ed2_data/met_driver/pseudo_drought' + shefpath='/scratch/ed2_data/met_driver/sheffield' else sitemet=${sitemetdef} pdroughtpath=${pdroughtpathdef} @@ -297,23 +297,29 @@ do atmco2=`echo ${oi} | awk '{print $57}'` thcrit=`echo ${oi} | awk '{print $58}'` smfire=`echo ${oi} | awk '{print $59}'` - isoilbc=`echo ${oi} | awk '{print $60}'` - imetrad=`echo ${oi} | awk '{print $61}'` - ibranch=`echo ${oi} | awk '{print $62}'` - icanrad=`echo ${oi} | awk '{print $63}'` - crown=`echo ${oi} | awk '{print $64}'` - ltransvis=`echo ${oi} | awk '{print $65}'` - lreflectvis=`echo ${oi} | awk '{print $66}'` - ltransnir=`echo ${oi} | awk '{print $67}'` - lreflectnir=`echo ${oi} | awk '{print $68}'` - orienttree=`echo ${oi} | awk '{print $69}'` - orientgrass=`echo ${oi} | awk '{print $70}'` - clumptree=`echo ${oi} | awk '{print $71}'` - clumpgrass=`echo ${oi} | awk '{print $72}'` - ivegtdyn=`echo ${oi} | awk '{print $73}'` - igndvap=`echo ${oi} | awk '{print $74}'` - iphen=`echo ${oi} | awk '{print $75}'` - iallom=`echo ${oi} | awk '{print $76}'` + ifire=`echo ${oi} | awk '{print $60}'` + fireparm=`echo ${oi} | awk '{print $61}'` + ipercol=`echo ${oi} | awk '{print $62}'` + isoilbc=`echo ${oi} | awk '{print $63}'` + runoff=`echo ${oi} | awk '{print $64}'` + imetrad=`echo ${oi} | awk '{print $65}'` + ibranch=`echo ${oi} | awk '{print $66}'` + icanrad=`echo ${oi} | awk '{print $67}'` + crown=`echo ${oi} | awk '{print $68}'` + ltransvis=`echo ${oi} | awk '{print $69}'` + lreflectvis=`echo ${oi} | awk '{print $70}'` + ltransnir=`echo ${oi} | awk '{print $71}'` + lreflectnir=`echo ${oi} | awk '{print $72}'` + orienttree=`echo ${oi} | awk '{print $73}'` + orientgrass=`echo ${oi} | awk '{print $74}'` + clumptree=`echo ${oi} | awk '{print $75}'` + clumpgrass=`echo ${oi} | awk '{print $76}'` + ivegtdyn=`echo ${oi} | awk '{print $77}'` + igndvap=`echo ${oi} | awk '{print $78}'` + iphen=`echo ${oi} | awk '{print $79}'` + iallom=`echo ${oi} | awk '{print $80}'` + ibigleaf=`echo ${oi} | awk '{print $81}'` + irepro=`echo ${oi} | awk '{print $82}'` #---------------------------------------------------------------------------------------# @@ -459,27 +465,27 @@ do # Determine which PFTs to use based on the "iata" code. # #---------------------------------------------------------------------------------------# case ${polyiata} in - wch|zmh|nqn) - pfts='5,6,7,8,9,10,11,17' - crop=5 + tzi|zmh|nqn) + pfts='6,7,9,10,11,16,17' + crop=16 plantation=17 ;; - hvd) - pfts='5,6,8,9,10,11' - crop=5 - plantation=8 + hvd|wch|tqh) + pfts='6,8,9,10,11,16,17' + crop=16 + plantation=17 ;; - aei|asu|cnf|bnu|cwb|erm|iqq|ipv|mgf|rao|sla|zpe|kna) + asu|cnf|bnu|cwb|erm|iqq|ipv|mgf|rao|sla|zpe|kna|sfn) pfts='1,2,3,4,16,17' crop=16 plantation=17 ;; - fns) + fns*) pfts='1,16' crop=1 plantation=17 ;; - s77) + s77*) pfts='1,16' crop=16 plantation=17 @@ -517,8 +523,14 @@ do ;; Harvard) metdriverdb=${sitemet}'/Harvard_Forest/Harvard_Forest_HEADER' - metcyc1=1993 - metcycf=2008 + metcyc1=1992 + metcycf=2003 + imetavg=1 + ;; + Tonzi) + metdriverdb=${sitemet}'/Tonzi/Tonzi_HEADER' + metcyc1=2000 + metcycf=2010 imetavg=1 ;; Manaus_KM34) @@ -539,6 +551,12 @@ do metcycf=2003 imetavg=1 ;; + Santarem_KM66) + metdriverdb=${sitemet}'/Santarem_KM66/Santarem_KM66_HEADER' + metcyc1=2002 + metcycf=2010 + imetavg=1 + ;; Santarem_KM67) metdriverdb=${sitemet}'/Santarem_KM67/Santarem_KM67_HEADER' metcyc1=2002 @@ -569,12 +587,6 @@ do metcycf=2009 imetavg=1 ;; - Guyaflux_Natalia) - metdriverdb=${sitemet}'/Guyaflux_Natalia/Guyaflux_Natalia_HEADER' - metcyc1=2007 - metcycf=2009 - imetavg=1 - ;; Sheffield) if [ 'x'${shefpath} == 'x' ] then @@ -619,6 +631,12 @@ do #------------------------------------------------------------------------------------# case ${metdriver} in + Santarem_KM66) + metdriverdb=${pdroughtpath}'/Santarem_KM66/S66_'${metdesc}'_HEADER' + metcyc1=1600 + metcycf=1609 + imetavg=1 + ;; Santarem_KM67) metdriverdb=${pdroughtpath}'/Santarem_KM67/S67_'${metdesc}'_HEADER' metcyc1=1600 @@ -952,7 +970,7 @@ do then sed -i s@CRASHED@HISTORY@g ${here}/${polyname}/statusrun.txt runt='HISTORY' - toler=`calc.sh ${toler}/10` + # toler=`calc.sh ${toler}/10` fi #---------------------------------------------------------------------------------------# @@ -969,6 +987,12 @@ do then thissfilin=${fullygrown} case ${polyiata} in + hvd) + thissfilin=${bioinit}'/harvard.' + ;; + s66) + thissfilin=${bioinit}'/km67_ustein_newallom.' + ;; s67) thissfilin=${bioinit}'/km67_ustein_newallom.' ;; @@ -1092,8 +1116,12 @@ do sed -i s@myatmco2@${atmco2}@g ${ED2IN} sed -i s@mythcrit@${thcrit}@g ${ED2IN} sed -i s@mysmfire@${smfire}@g ${ED2IN} + sed -i s@myfire@${ifire}@g ${ED2IN} + sed -i s@myfuel@${fireparm}@g ${ED2IN} sed -i s@mymetavg@${imetavg}@g ${ED2IN} + sed -i s@mypercol@${ipercol}@g ${ED2IN} sed -i s@mysoilbc@${isoilbc}@g ${ED2IN} + sed -i s@myrunoff@${runoff}@g ${ED2IN} sed -i s@mymetrad@${imetrad}@g ${ED2IN} sed -i s@mybranch@${ibranch}@g ${ED2IN} sed -i s@mycanrad@${icanrad}@g ${ED2IN} @@ -1107,6 +1135,8 @@ do sed -i s@myclumptree@${clumptree}@g ${ED2IN} sed -i s@myclumpgrass@${clumpgrass}@g ${ED2IN} sed -i s@myvegtdyn@${ivegtdyn}@g ${ED2IN} + sed -i s@mybigleaf@${ibigleaf}@g ${ED2IN} + sed -i s@myrepro@${irepro}@g ${ED2IN} sed -i s@myubmin@${ubmin}@g ${ED2IN} sed -i s@myugbmin@${ugbmin}@g ${ED2IN} sed -i s@myustmin@${ustmin}@g ${ED2IN} diff --git a/ED/Template/stopalljobs.sh b/ED/Template/stopalljobs.sh index 1e79bb2ee..0eedcb5b0 100755 --- a/ED/Template/stopalljobs.sh +++ b/ED/Template/stopalljobs.sh @@ -113,23 +113,29 @@ do atmco2=`echo ${oi} | awk '{print $57}'` thcrit=`echo ${oi} | awk '{print $58}'` smfire=`echo ${oi} | awk '{print $59}'` - isoilbc=`echo ${oi} | awk '{print $60}'` - imetrad=`echo ${oi} | awk '{print $61}'` - ibranch=`echo ${oi} | awk '{print $62}'` - icanrad=`echo ${oi} | awk '{print $63}'` - crown=`echo ${oi} | awk '{print $64}'` - ltransvis=`echo ${oi} | awk '{print $65}'` - lreflectvis=`echo ${oi} | awk '{print $66}'` - ltransnir=`echo ${oi} | awk '{print $67}'` - lreflectnir=`echo ${oi} | awk '{print $68}'` - orienttree=`echo ${oi} | awk '{print $69}'` - orientgrass=`echo ${oi} | awk '{print $70}'` - clumptree=`echo ${oi} | awk '{print $71}'` - clumpgrass=`echo ${oi} | awk '{print $72}'` - ivegtdyn=`echo ${oi} | awk '{print $73}'` - igndvap=`echo ${oi} | awk '{print $74}'` - iphen=`echo ${oi} | awk '{print $75}'` - iallom=`echo ${oi} | awk '{print $76}'` + ifire=`echo ${oi} | awk '{print $60}'` + fireparm=`echo ${oi} | awk '{print $61}'` + ipercol=`echo ${oi} | awk '{print $62}'` + isoilbc=`echo ${oi} | awk '{print $63}'` + runoff=`echo ${oi} | awk '{print $64}'` + imetrad=`echo ${oi} | awk '{print $65}'` + ibranch=`echo ${oi} | awk '{print $66}'` + icanrad=`echo ${oi} | awk '{print $67}'` + crown=`echo ${oi} | awk '{print $68}'` + ltransvis=`echo ${oi} | awk '{print $69}'` + lreflectvis=`echo ${oi} | awk '{print $70}'` + ltransnir=`echo ${oi} | awk '{print $71}'` + lreflectnir=`echo ${oi} | awk '{print $72}'` + orienttree=`echo ${oi} | awk '{print $73}'` + orientgrass=`echo ${oi} | awk '{print $74}'` + clumptree=`echo ${oi} | awk '{print $75}'` + clumpgrass=`echo ${oi} | awk '{print $76}'` + ivegtdyn=`echo ${oi} | awk '{print $77}'` + igndvap=`echo ${oi} | awk '{print $78}'` + iphen=`echo ${oi} | awk '{print $79}'` + iallom=`echo ${oi} | awk '{print $80}'` + ibigleaf=`echo ${oi} | awk '{print $81}'` + irepro=`echo ${oi} | awk '{print $82}'` #---------------------------------------------------------------------------------------# bkill -J ${desc}-${polyname} -q ${queue} diff --git a/ED/Template/submitter.sh b/ED/Template/submitter.sh index ebc41ada5..6a24e2f83 100755 --- a/ED/Template/submitter.sh +++ b/ED/Template/submitter.sh @@ -86,23 +86,29 @@ do atmco2=`echo ${oi} | awk '{print $57}'` thcrit=`echo ${oi} | awk '{print $58}'` smfire=`echo ${oi} | awk '{print $59}'` - isoilbc=`echo ${oi} | awk '{print $60}'` - imetrad=`echo ${oi} | awk '{print $61}'` - ibranch=`echo ${oi} | awk '{print $62}'` - icanrad=`echo ${oi} | awk '{print $63}'` - crown=`echo ${oi} | awk '{print $64}'` - ltransvis=`echo ${oi} | awk '{print $65}'` - lreflectvis=`echo ${oi} | awk '{print $66}'` - ltransnir=`echo ${oi} | awk '{print $67}'` - lreflectnir=`echo ${oi} | awk '{print $68}'` - orienttree=`echo ${oi} | awk '{print $69}'` - orientgrass=`echo ${oi} | awk '{print $70}'` - clumptree=`echo ${oi} | awk '{print $71}'` - clumpgrass=`echo ${oi} | awk '{print $72}'` - ivegtdyn=`echo ${oi} | awk '{print $73}'` - igndvap=`echo ${oi} | awk '{print $74}'` - iphen=`echo ${oi} | awk '{print $75}'` - iallom=`echo ${oi} | awk '{print $76}'` + ifire=`echo ${oi} | awk '{print $60}'` + fireparm=`echo ${oi} | awk '{print $61}'` + ipercol=`echo ${oi} | awk '{print $62}'` + isoilbc=`echo ${oi} | awk '{print $63}'` + runoff=`echo ${oi} | awk '{print $64}'` + imetrad=`echo ${oi} | awk '{print $65}'` + ibranch=`echo ${oi} | awk '{print $66}'` + icanrad=`echo ${oi} | awk '{print $67}'` + crown=`echo ${oi} | awk '{print $68}'` + ltransvis=`echo ${oi} | awk '{print $69}'` + lreflectvis=`echo ${oi} | awk '{print $70}'` + ltransnir=`echo ${oi} | awk '{print $71}'` + lreflectnir=`echo ${oi} | awk '{print $72}'` + orienttree=`echo ${oi} | awk '{print $73}'` + orientgrass=`echo ${oi} | awk '{print $74}'` + clumptree=`echo ${oi} | awk '{print $75}'` + clumpgrass=`echo ${oi} | awk '{print $76}'` + ivegtdyn=`echo ${oi} | awk '{print $77}'` + igndvap=`echo ${oi} | awk '{print $78}'` + iphen=`echo ${oi} | awk '{print $79}'` + iallom=`echo ${oi} | awk '{print $80}'` + ibigleaf=`echo ${oi} | awk '{print $81}'` + irepro=`echo ${oi} | awk '{print $82}'` #---------------------------------------------------------------------------------------# diff --git a/ED/build/bin/2ndcomp.sh b/ED/build/bin/2ndcomp.sh index d313d66b2..8adf06e51 100755 --- a/ED/build/bin/2ndcomp.sh +++ b/ED/build/bin/2ndcomp.sh @@ -3,6 +3,7 @@ rm -fv edmain.o edmain.mod rm -fv allometry.o allometry.mod rm -fv an_header.o an_header.mod rm -fv average_utils.o average_utils.mod +rm -fv bdf2_solver.o bdf2_solver.mod rm -fv budget_utils.o budget_utils.mod rm -fv canopy_air_coms.o canopy_air_coms.mod rm -fv canopy_layer_coms.o canopy_layer_coms.mod @@ -13,6 +14,7 @@ rm -fv charutils.o charutils.mod rm -fv consts_coms.o consts_coms.mod rm -fv dateutils.o dateutils.mod rm -fv decomp_coms.o decomp_coms.mod +rm -fv detailed_coms.o detailed_coms.mod rm -fv disturbance.o disturbance.mod rm -fv disturb_coms.o disturb_coms.mod rm -fv edio.o edio.mod @@ -62,6 +64,7 @@ rm -fv h5_output.o h5_output.mod rm -fv hdf5_coms.o hdf5_coms.mod rm -fv hdf5_utils.o hdf5_utils.mod rm -fv heun_driver.o heun_driver.mod +rm -fv hybrid_driver.o hybrid_driver.mod rm -fv hydrology_coms.o hydrology_coms.mod rm -fv hydrology_constants.o hydrology_constants.mod rm -fv init_hydro_sites.o init_hydro_sites.mod diff --git a/ED/build/bin/dependency.mk b/ED/build/bin/dependency.mk index ed2a6a277..5783ef47e 100644 --- a/ED/build/bin/dependency.mk +++ b/ED/build/bin/dependency.mk @@ -1,27 +1,32 @@ # DO NOT DELETE THIS LINE - used by make depend ed_1st.o: ed_misc_coms.mod ed_para_coms.mod ed_state_vars.mod -ed_driver.o: consts_coms.mod ed_misc_coms.mod ed_node_coms.mod ed_state_vars.mod -ed_driver.o: fuse_fiss_utils.mod grid_coms.mod soil_coms.mod +ed_driver.o: consts_coms.mod detailed_coms.mod ed_misc_coms.mod ed_node_coms.mod +ed_driver.o: ed_state_vars.mod fuse_fiss_utils.mod grid_coms.mod +ed_driver.o: phenology_aux.mod soil_coms.mod ed_met_driver.o: canopy_air_coms.mod canopy_radiation_coms.mod consts_coms.mod ed_met_driver.o: ed_max_dims.mod ed_misc_coms.mod ed_node_coms.mod ed_met_driver.o: ed_state_vars.mod grid_coms.mod hdf5_utils.mod mem_polygons.mod ed_met_driver.o: met_driver_coms.mod pft_coms.mod therm_lib.mod -ed_model.o: consts_coms.mod disturb_coms.mod ed_misc_coms.mod ed_node_coms.mod -ed_model.o: ed_state_vars.mod grid_coms.mod mem_polygons.mod rk4_coms.mod -ed_model.o: rk4_driver.mod +ed_model.o: consts_coms.mod ed_misc_coms.mod ed_node_coms.mod ed_state_vars.mod +ed_model.o: grid_coms.mod mem_polygons.mod rk4_coms.mod rk4_driver.mod +bdf2_solver.o: consts_coms.mod ed_misc_coms.mod ed_state_vars.mod +bdf2_solver.o: ed_therm_lib.mod grid_coms.mod rk4_coms.mod soil_coms.mod +bdf2_solver.o: therm_lib8.mod canopy_struct_dynamics.o: allometry.mod canopy_air_coms.mod canopy_struct_dynamics.o: canopy_layer_coms.mod consts_coms.mod canopy_struct_dynamics.o: ed_state_vars.mod grid_coms.mod met_driver_coms.mod -canopy_struct_dynamics.o: pft_coms.mod physiology_coms.mod rk4_coms.mod -canopy_struct_dynamics.o: soil_coms.mod +canopy_struct_dynamics.o: pft_coms.mod phenology_coms.mod physiology_coms.mod +canopy_struct_dynamics.o: rk4_coms.mod soil_coms.mod therm_lib.mod disturbance.o: allometry.mod consts_coms.mod decomp_coms.mod disturb_coms.mod disturbance.o: ed_max_dims.mod ed_misc_coms.mod ed_state_vars.mod disturbance.o: ed_therm_lib.mod fuse_fiss_utils.mod grid_coms.mod -disturbance.o: mem_polygons.mod pft_coms.mod phenology_coms.mod -euler_driver.o: canopy_air_coms.mod canopy_struct_dynamics.mod consts_coms.mod -euler_driver.o: ed_max_dims.mod ed_misc_coms.mod ed_state_vars.mod grid_coms.mod +disturbance.o: mem_polygons.mod pft_coms.mod phenology_aux.mod +disturbance.o: phenology_coms.mod +euler_driver.o: canopy_air_coms.mod consts_coms.mod ed_max_dims.mod +euler_driver.o: ed_misc_coms.mod ed_state_vars.mod grid_coms.mod euler_driver.o: hydrology_coms.mod met_driver_coms.mod rk4_coms.mod -euler_driver.o: rk4_driver.mod rk4_stepper.mod soil_coms.mod +euler_driver.o: rk4_driver.mod rk4_stepper.mod soil_coms.mod therm_lib.mod +euler_driver.o: therm_lib8.mod events.o: allometry.mod consts_coms.mod decomp_coms.mod disturbance_utils.mod events.o: ed_misc_coms.mod ed_state_vars.mod ed_therm_lib.mod events.o: fuse_fiss_utils.mod grid_coms.mod pft_coms.mod therm_lib.mod @@ -30,14 +35,19 @@ farq_leuning.o: physiology_coms.mod rk4_coms.mod therm_lib8.mod fire.o: allometry.mod consts_coms.mod disturb_coms.mod ed_misc_coms.mod fire.o: ed_state_vars.mod grid_coms.mod soil_coms.mod forestry.o: allometry.mod disturb_coms.mod disturbance_utils.mod ed_max_dims.mod -forestry.o: ed_state_vars.mod fuse_fiss_utils.mod grid_coms.mod +forestry.o: ed_misc_coms.mod ed_state_vars.mod fuse_fiss_utils.mod grid_coms.mod growth_balive.o: allometry.mod consts_coms.mod decomp_coms.mod ed_max_dims.mod growth_balive.o: ed_misc_coms.mod ed_state_vars.mod ed_therm_lib.mod growth_balive.o: grid_coms.mod mortality.mod pft_coms.mod physiology_coms.mod -heun_driver.o: canopy_air_coms.mod canopy_struct_dynamics.mod consts_coms.mod -heun_driver.o: ed_max_dims.mod ed_misc_coms.mod ed_state_vars.mod grid_coms.mod +heun_driver.o: canopy_air_coms.mod consts_coms.mod ed_max_dims.mod +heun_driver.o: ed_misc_coms.mod ed_state_vars.mod grid_coms.mod heun_driver.o: hydrology_coms.mod met_driver_coms.mod rk4_coms.mod -heun_driver.o: rk4_driver.mod rk4_stepper.mod soil_coms.mod +heun_driver.o: rk4_driver.mod rk4_stepper.mod soil_coms.mod therm_lib.mod +heun_driver.o: therm_lib8.mod +hybrid_driver.o: consts_coms.mod ed_max_dims.mod ed_misc_coms.mod +hybrid_driver.o: ed_state_vars.mod grid_coms.mod hydrology_coms.mod +hybrid_driver.o: met_driver_coms.mod rk4_coms.mod rk4_driver.mod rk4_stepper.mod +hybrid_driver.o: soil_coms.mod therm_lib8.mod lsm_hyd.o: consts_coms.mod ed_misc_coms.mod ed_node_coms.mod ed_state_vars.mod lsm_hyd.o: grid_coms.mod hydrology_coms.mod hydrology_constants.mod pft_coms.mod lsm_hyd.o: soil_coms.mod therm_lib.mod @@ -45,12 +55,13 @@ mortality.o: consts_coms.mod disturb_coms.mod ed_max_dims.mod ed_misc_coms.mod mortality.o: ed_state_vars.mod pft_coms.mod multiple_scatter.o: canopy_radiation_coms.mod consts_coms.mod ed_max_dims.mod multiple_scatter.o: rk4_coms.mod -phenology_aux.o: allometry.mod consts_coms.mod ed_max_dims.mod ed_misc_coms.mod -phenology_aux.o: ed_state_vars.mod ed_therm_lib.mod grid_coms.mod pft_coms.mod -phenology_aux.o: phenology_coms.mod soil_coms.mod +phenology_aux.o: allometry.mod consts_coms.mod ed_max_dims.mod ed_state_vars.mod +phenology_aux.o: ed_therm_lib.mod grid_coms.mod pft_coms.mod phenology_coms.mod +phenology_aux.o: soil_coms.mod phenology_driv.o: allometry.mod consts_coms.mod decomp_coms.mod ed_max_dims.mod phenology_driv.o: ed_misc_coms.mod ed_state_vars.mod ed_therm_lib.mod -phenology_driv.o: grid_coms.mod pft_coms.mod phenology_coms.mod soil_coms.mod +phenology_driv.o: grid_coms.mod pft_coms.mod phenology_aux.mod +phenology_driv.o: phenology_coms.mod soil_coms.mod photosyn_driv.o: allometry.mod consts_coms.mod ed_max_dims.mod ed_misc_coms.mod photosyn_driv.o: ed_state_vars.mod farq_leuning.mod met_driver_coms.mod photosyn_driv.o: pft_coms.mod phenology_coms.mod physiology_coms.mod @@ -59,15 +70,16 @@ radiate_driver.o: allometry.mod canopy_layer_coms.mod canopy_radiation_coms.mod radiate_driver.o: consts_coms.mod ed_max_dims.mod ed_misc_coms.mod radiate_driver.o: ed_state_vars.mod grid_coms.mod soil_coms.mod reproduction.o: allometry.mod consts_coms.mod decomp_coms.mod ed_max_dims.mod -reproduction.o: ed_state_vars.mod ed_therm_lib.mod fuse_fiss_utils.mod -reproduction.o: grid_coms.mod mem_polygons.mod pft_coms.mod phenology_coms.mod +reproduction.o: ed_misc_coms.mod ed_state_vars.mod ed_therm_lib.mod +reproduction.o: fuse_fiss_utils.mod grid_coms.mod mem_polygons.mod pft_coms.mod +reproduction.o: phenology_aux.mod phenology_coms.mod rk4_derivs.o: canopy_struct_dynamics.mod consts_coms.mod ed_max_dims.mod rk4_derivs.o: ed_misc_coms.mod ed_state_vars.mod grid_coms.mod pft_coms.mod rk4_derivs.o: physiology_coms.mod rk4_coms.mod soil_coms.mod therm_lib8.mod -rk4_driver.o: allometry.mod canopy_air_coms.mod canopy_struct_dynamics.mod -rk4_driver.o: consts_coms.mod disturb_coms.mod ed_misc_coms.mod -rk4_driver.o: ed_state_vars.mod grid_coms.mod met_driver_coms.mod -rk4_driver.o: phenology_coms.mod rk4_coms.mod soil_coms.mod therm_lib.mod +rk4_driver.o: allometry.mod canopy_air_coms.mod consts_coms.mod disturb_coms.mod +rk4_driver.o: ed_misc_coms.mod ed_state_vars.mod grid_coms.mod +rk4_driver.o: met_driver_coms.mod phenology_coms.mod rk4_coms.mod soil_coms.mod +rk4_driver.o: therm_lib.mod rk4_integ_utils.o: canopy_air_coms.mod consts_coms.mod ed_max_dims.mod rk4_integ_utils.o: ed_misc_coms.mod ed_state_vars.mod grid_coms.mod rk4_integ_utils.o: hydrology_coms.mod rk4_coms.mod rk4_stepper.mod soil_coms.mod @@ -84,9 +96,9 @@ structural_growth.o: ed_max_dims.mod ed_misc_coms.mod ed_state_vars.mod structural_growth.o: ed_therm_lib.mod pft_coms.mod twostream_rad.o: canopy_radiation_coms.mod consts_coms.mod ed_max_dims.mod twostream_rad.o: rk4_coms.mod -vegetation_dynamics.o: consts_coms.mod disturb_coms.mod disturbance_utils.mod -vegetation_dynamics.o: ed_misc_coms.mod ed_state_vars.mod fuse_fiss_utils.mod -vegetation_dynamics.o: grid_coms.mod growth_balive.mod mem_polygons.mod +vegetation_dynamics.o: consts_coms.mod disturbance_utils.mod ed_misc_coms.mod +vegetation_dynamics.o: ed_state_vars.mod fuse_fiss_utils.mod grid_coms.mod +vegetation_dynamics.o: growth_balive.mod mem_polygons.mod ed_init.o: consts_coms.mod ed_max_dims.mod ed_misc_coms.mod ed_node_coms.mod ed_init.o: ed_state_vars.mod ed_work_vars.mod grid_coms.mod mem_polygons.mod ed_init.o: phenology_coms.mod phenology_startup.mod rk4_coms.mod soil_coms.mod @@ -99,10 +111,10 @@ ed_nbg_init.o: ed_state_vars.mod fuse_fiss_utils.mod grid_coms.mod pft_coms.mod ed_nbg_init.o: physiology_coms.mod ed_params.o: allometry.mod canopy_air_coms.mod canopy_layer_coms.mod ed_params.o: canopy_radiation_coms.mod consts_coms.mod decomp_coms.mod -ed_params.o: disturb_coms.mod ed_max_dims.mod ed_misc_coms.mod -ed_params.o: fusion_fission_coms.mod grid_coms.mod hydrology_coms.mod -ed_params.o: met_driver_coms.mod pft_coms.mod phenology_coms.mod -ed_params.o: physiology_coms.mod rk4_coms.mod soil_coms.mod +ed_params.o: detailed_coms.mod disturb_coms.mod ed_max_dims.mod ed_misc_coms.mod +ed_params.o: ed_therm_lib.mod fusion_fission_coms.mod grid_coms.mod +ed_params.o: hydrology_coms.mod met_driver_coms.mod pft_coms.mod +ed_params.o: phenology_coms.mod physiology_coms.mod rk4_coms.mod soil_coms.mod ed_type_init.o: allometry.mod canopy_air_coms.mod consts_coms.mod ed_type_init.o: ed_max_dims.mod ed_misc_coms.mod ed_state_vars.mod ed_type_init.o: ed_therm_lib.mod grid_coms.mod pft_coms.mod phenology_coms.mod @@ -112,31 +124,30 @@ init_hydro_sites.o: grid_coms.mod mem_polygons.mod soil_coms.mod landuse_init.o: consts_coms.mod disturb_coms.mod ed_max_dims.mod landuse_init.o: ed_misc_coms.mod ed_state_vars.mod grid_coms.mod phenology_startup.o: ed_max_dims.mod ed_misc_coms.mod ed_state_vars.mod -phenology_startup.o: grid_coms.mod phenology_coms.mod +phenology_startup.o: grid_coms.mod phenology_aux.mod phenology_coms.mod average_utils.o: allometry.mod canopy_radiation_coms.mod consts_coms.mod average_utils.o: ed_max_dims.mod ed_misc_coms.mod ed_state_vars.mod average_utils.o: grid_coms.mod pft_coms.mod therm_lib.mod -ed_init_full_history.o: allometry.mod c34constants.mod consts_coms.mod -ed_init_full_history.o: ed_max_dims.mod ed_misc_coms.mod ed_node_coms.mod -ed_init_full_history.o: ed_state_vars.mod fusion_fission_coms.mod grid_coms.mod -ed_init_full_history.o: hdf5_coms.mod phenology_startup.mod -ed_init_full_history.o: soil_coms.mod therm_lib.mod +ed_init_full_history.o: allometry.mod ed_max_dims.mod ed_misc_coms.mod +ed_init_full_history.o: ed_node_coms.mod ed_state_vars.mod +ed_init_full_history.o: fusion_fission_coms.mod grid_coms.mod +ed_init_full_history.o: hdf5_coms.mod phenology_startup.mod soil_coms.mod ed_load_namelist.o: canopy_air_coms.mod canopy_layer_coms.mod ed_load_namelist.o: canopy_radiation_coms.mod consts_coms.mod decomp_coms.mod -ed_load_namelist.o: disturb_coms.mod ed_max_dims.mod ed_misc_coms.mod -ed_load_namelist.o: ed_para_coms.mod ename_coms.mod grid_coms.mod -ed_load_namelist.o: mem_polygons.mod met_driver_coms.mod optimiz_coms.mod -ed_load_namelist.o: pft_coms.mod phenology_coms.mod physiology_coms.mod -ed_load_namelist.o: rk4_coms.mod soil_coms.mod +ed_load_namelist.o: detailed_coms.mod disturb_coms.mod ed_max_dims.mod +ed_load_namelist.o: ed_misc_coms.mod ed_para_coms.mod ename_coms.mod +ed_load_namelist.o: grid_coms.mod mem_polygons.mod met_driver_coms.mod +ed_load_namelist.o: optimiz_coms.mod pft_coms.mod phenology_coms.mod +ed_load_namelist.o: physiology_coms.mod rk4_coms.mod soil_coms.mod ed_opspec.o: canopy_air_coms.mod canopy_layer_coms.mod canopy_radiation_coms.mod -ed_opspec.o: consts_coms.mod decomp_coms.mod disturb_coms.mod ed_max_dims.mod -ed_opspec.o: ed_misc_coms.mod ed_para_coms.mod grid_coms.mod mem_polygons.mod -ed_opspec.o: met_driver_coms.mod pft_coms.mod phenology_coms.mod -ed_opspec.o: physiology_coms.mod rk4_coms.mod soil_coms.mod +ed_opspec.o: consts_coms.mod decomp_coms.mod detailed_coms.mod disturb_coms.mod +ed_opspec.o: ed_max_dims.mod ed_misc_coms.mod ed_para_coms.mod grid_coms.mod +ed_opspec.o: mem_polygons.mod met_driver_coms.mod pft_coms.mod +ed_opspec.o: phenology_coms.mod physiology_coms.mod rk4_coms.mod soil_coms.mod ed_print.o: ed_max_dims.mod ed_misc_coms.mod ed_node_coms.mod ed_state_vars.mod ed_print.o: ed_var_tables.mod -ed_read_ed10_20_history.o: allometry.mod consts_coms.mod disturb_coms.mod -ed_read_ed10_20_history.o: ed_max_dims.mod ed_misc_coms.mod ed_state_vars.mod +ed_read_ed10_20_history.o: allometry.mod consts_coms.mod ed_max_dims.mod +ed_read_ed10_20_history.o: ed_misc_coms.mod ed_state_vars.mod ed_read_ed10_20_history.o: fuse_fiss_utils.mod grid_coms.mod mem_polygons.mod ed_read_ed10_20_history.o: pft_coms.mod ed_read_ed21_history.o: allometry.mod consts_coms.mod disturb_coms.mod @@ -148,12 +159,11 @@ ed_xml_config.o: ed_max_dims.mod ed_misc_coms.mod fusion_fission_coms.mod ed_xml_config.o: grid_coms.mod hydrology_coms.mod met_driver_coms.mod ed_xml_config.o: pft_coms.mod phenology_coms.mod physiology_coms.mod ed_xml_config.o: rk4_coms.mod soil_coms.mod -edio.o: c34constants.mod consts_coms.mod ed_max_dims.mod ed_misc_coms.mod -edio.o: ed_node_coms.mod ed_state_vars.mod grid_coms.mod pft_coms.mod -edio.o: soil_coms.mod therm_lib.mod -h5_output.o: an_header.mod c34constants.mod ed_max_dims.mod ed_misc_coms.mod -h5_output.o: ed_node_coms.mod ed_state_vars.mod ed_var_tables.mod -h5_output.o: fusion_fission_coms.mod grid_coms.mod hdf5_coms.mod +edio.o: consts_coms.mod ed_max_dims.mod ed_misc_coms.mod ed_node_coms.mod +edio.o: ed_state_vars.mod grid_coms.mod pft_coms.mod soil_coms.mod therm_lib.mod +h5_output.o: an_header.mod ed_max_dims.mod ed_misc_coms.mod ed_node_coms.mod +h5_output.o: ed_state_vars.mod ed_var_tables.mod fusion_fission_coms.mod +h5_output.o: grid_coms.mod hdf5_coms.mod leaf_database.o: grid_coms.mod hdf5_utils.mod soil_coms.mod canopy_air_coms.o: consts_coms.mod therm_lib.mod therm_lib8.mod canopy_radiation_coms.o: ed_max_dims.mod @@ -165,10 +175,10 @@ ed_mem_alloc.o: ed_max_dims.mod ed_mem_grid_dim_defs.mod ed_node_coms.mod ed_mem_alloc.o: ed_state_vars.mod ed_work_vars.mod grid_coms.mod ed_mem_alloc.o: mem_polygons.mod ed_misc_coms.o: ed_max_dims.mod -ed_state_vars.o: c34constants.mod disturb_coms.mod ed_max_dims.mod -ed_state_vars.o: ed_misc_coms.mod ed_node_coms.mod ed_var_tables.mod -ed_state_vars.o: fusion_fission_coms.mod grid_coms.mod met_driver_coms.mod -ed_state_vars.o: phenology_coms.mod soil_coms.mod +ed_state_vars.o: disturb_coms.mod ed_max_dims.mod ed_misc_coms.mod +ed_state_vars.o: ed_node_coms.mod ed_var_tables.mod fusion_fission_coms.mod +ed_state_vars.o: grid_coms.mod met_driver_coms.mod phenology_coms.mod +ed_state_vars.o: soil_coms.mod ed_var_tables.o: ed_max_dims.mod ed_work_vars.o: ed_max_dims.mod ename_coms.o: ed_max_dims.mod @@ -185,12 +195,13 @@ rk4_coms.o: consts_coms.mod ed_max_dims.mod ed_misc_coms.mod grid_coms.mod rk4_coms.o: soil_coms.mod therm_lib8.mod soil_coms.o: ed_max_dims.mod grid_coms.mod ed_mpass_init.o: canopy_air_coms.mod canopy_layer_coms.mod -ed_mpass_init.o: canopy_radiation_coms.mod decomp_coms.mod disturb_coms.mod -ed_mpass_init.o: ed_max_dims.mod ed_misc_coms.mod ed_node_coms.mod -ed_mpass_init.o: ed_para_coms.mod ed_state_vars.mod ed_work_vars.mod -ed_mpass_init.o: grid_coms.mod mem_polygons.mod met_driver_coms.mod -ed_mpass_init.o: optimiz_coms.mod pft_coms.mod phenology_coms.mod -ed_mpass_init.o: physiology_coms.mod rk4_coms.mod soil_coms.mod +ed_mpass_init.o: canopy_radiation_coms.mod decomp_coms.mod detailed_coms.mod +ed_mpass_init.o: disturb_coms.mod ed_max_dims.mod ed_misc_coms.mod +ed_mpass_init.o: ed_node_coms.mod ed_para_coms.mod ed_state_vars.mod +ed_mpass_init.o: ed_work_vars.mod grid_coms.mod mem_polygons.mod +ed_mpass_init.o: met_driver_coms.mod optimiz_coms.mod pft_coms.mod +ed_mpass_init.o: phenology_coms.mod physiology_coms.mod rk4_coms.mod +ed_mpass_init.o: soil_coms.mod ed_node_coms.o: ed_max_dims.mod ed_para_coms.o: ed_max_dims.mod ed_para_init.o: ed_max_dims.mod ed_misc_coms.mod ed_node_coms.mod @@ -200,6 +211,7 @@ allometry.o: consts_coms.mod ed_misc_coms.mod grid_coms.mod pft_coms.mod allometry.o: rk4_coms.mod soil_coms.mod budget_utils.o: consts_coms.mod ed_max_dims.mod ed_misc_coms.mod budget_utils.o: ed_state_vars.mod grid_coms.mod rk4_coms.mod soil_coms.mod +budget_utils.o: therm_lib.mod dateutils.o: consts_coms.mod ed_filelist.o: ed_max_dims.mod ed_grid.o: consts_coms.mod ed_max_dims.mod ed_node_coms.mod grid_coms.mod @@ -208,11 +220,11 @@ ed_therm_lib.o: ed_max_dims.mod ed_misc_coms.mod ed_state_vars.mod grid_coms.mod ed_therm_lib.o: pft_coms.mod rk4_coms.mod soil_coms.mod therm_lib.mod ed_therm_lib.o: therm_lib8.mod fatal_error.o: ed_node_coms.mod -fuse_fiss_utils.o: allometry.mod canopy_layer_coms.mod consts_coms.mod -fuse_fiss_utils.o: decomp_coms.mod disturb_coms.mod ed_max_dims.mod -fuse_fiss_utils.o: ed_misc_coms.mod ed_node_coms.mod ed_state_vars.mod -fuse_fiss_utils.o: fusion_fission_coms.mod grid_coms.mod mem_polygons.mod -fuse_fiss_utils.o: pft_coms.mod soil_coms.mod therm_lib.mod +fuse_fiss_utils.o: allometry.mod canopy_layer_coms.mod decomp_coms.mod +fuse_fiss_utils.o: disturb_coms.mod ed_max_dims.mod ed_misc_coms.mod +fuse_fiss_utils.o: ed_node_coms.mod ed_state_vars.mod fusion_fission_coms.mod +fuse_fiss_utils.o: grid_coms.mod mem_polygons.mod pft_coms.mod soil_coms.mod +fuse_fiss_utils.o: therm_lib.mod great_circle.o: consts_coms.mod hdf5_utils.o: hdf5_coms.mod invmondays.o: ed_misc_coms.mod @@ -239,6 +251,7 @@ canopy_radiation_coms.mod: canopy_radiation_coms.o canopy_struct_dynamics.mod: canopy_struct_dynamics.o consts_coms.mod: consts_coms.o decomp_coms.mod: decomp_coms.o +detailed_coms.mod: detailed_coms.o disturb_coms.mod: disturb_coms.o disturbance_utils.mod: disturbance.o ed_max_dims.mod: ed_max_dims.o @@ -269,6 +282,7 @@ met_driver_coms.mod: met_driver_coms.o mortality.mod: mortality.o optimiz_coms.mod: optimiz_coms.o pft_coms.mod: pft_coms.o +phenology_aux.mod: phenology_aux.o phenology_coms.mod: phenology_coms.o phenology_startup.mod: phenology_startup.o physiology_coms.mod: physiology_coms.o diff --git a/ED/build/bin/include.mk.opt.odyssey b/ED/build/bin/include.mk.opt.odyssey index 06518f4e2..25440c698 100644 --- a/ED/build/bin/include.mk.opt.odyssey +++ b/ED/build/bin/include.mk.opt.odyssey @@ -236,12 +236,12 @@ KIND_COMP=E #------------------------------------------------------------------------------------------# ifeq ($(KIND_COMP),A) USE_INTERF=0 - F_OPTS= -FR -O0 -recursive -Vaxlib -check all -g -fpe0 -ftz -gen-interfaces \ + F_OPTS= -FR -O0 -recursive -Vaxlib -check all -g -fpe0 -no-ftz -gen-interfaces \ -warn interfaces -debug extended -debug inline_debug_info \ -debug-parameters all -traceback -ftrapuv -fp-stack-check -implicitnone \ -openmp C_OPTS= -O0 -DLITTLE -g -traceback -debug extended - LOADER_OPTS= -FR -O0 -Vaxlib -check all -g -fpe0 -ftz -gen-interfaces \ + LOADER_OPTS= -FR -O0 -Vaxlib -check all -g -fpe0 -no-ftz -gen-interfaces \ -warn interfaces -debug extended -debug inline_debug_info \ -debug-parameters all -traceback -ftrapuv -fp-stack-check -implicitnone \ -openmp @@ -250,11 +250,11 @@ ifeq ($(KIND_COMP),A) endif ifeq ($(KIND_COMP),B) USE_INTERF=1 - F_OPTS= -FR -O0 -recursive -Vaxlib -check all -g -fpe0 -ftz -debug extended \ + F_OPTS= -FR -O0 -recursive -Vaxlib -check all -g -fpe0 -no-ftz -debug extended \ -debug inline_debug_info -debug-parameters all -traceback -ftrapuv \ -fp-stack-check -implicitnone -openmp C_OPTS= -O0 -DLITTLE -g -traceback -debug extended - LOADER_OPTS= -FR -O0 -Vaxlib -check all -g -fpe0 -ftz -debug extended \ + LOADER_OPTS= -FR -O0 -Vaxlib -check all -g -fpe0 -no-ftz -debug extended \ -debug inline_debug_info -debug-parameters all -traceback -ftrapuv \ -fp-stack-check -implicitnone -openmp C_LOADER_OPTS=-v -g -traceback @@ -262,11 +262,11 @@ ifeq ($(KIND_COMP),B) endif ifeq ($(KIND_COMP),C) USE_INTERF=1 - F_OPTS= -FR -O2 -recursive -Vaxlib -check all -g -fpe0 -ftz -debug extended \ + F_OPTS= -FR -O2 -recursive -Vaxlib -check all -g -fpe0 -no-ftz -debug extended \ -debug inline_debug_info -debug-parameters all -traceback -ftrapuv \ -fp-stack-check -implicitnone -openmp C_OPTS= -O2 -DLITTLE -g -traceback -debug extended - LOADER_OPTS= -FR -O2 -Vaxlib -check all -g -fpe0 -ftz -debug extended \ + LOADER_OPTS= -FR -O2 -Vaxlib -check all -g -fpe0 -no-ftz -debug extended \ -debug inline_debug_info -debug-parameters all -traceback -ftrapuv \ -fp-stack-check -implicitnone -openmp C_LOADER_OPTS=-v -g -traceback @@ -274,20 +274,20 @@ ifeq ($(KIND_COMP),C) endif ifeq ($(KIND_COMP),D) USE_INTERF=1 - F_OPTS= -FR -O2 -recursive -Vaxlib -check all -fpe0 -ftz -traceback -ftrapuv \ + F_OPTS= -FR -O2 -recursive -Vaxlib -check all -fpe0 -no-ftz -traceback -ftrapuv \ -fp-stack-check -implicitnone -openmp C_OPTS= -O2 -DLITTLE -traceback - LOADER_OPTS= -FR -O2 -Vaxlib -check all -fpe0 -ftz -traceback -ftrapuv -fp-stack-check \ + LOADER_OPTS= -FR -O2 -Vaxlib -check all -fpe0 -no-ftz -traceback -ftrapuv -fp-stack-check \ -implicitnone -openmp C_LOADER_OPTS=-v -traceback #---------------------------------------------------------------------------------------# endif ifeq ($(KIND_COMP),E) USE_INTERF=1 - F_OPTS= -FR -O3 -recursive -Vaxlib -traceback -axP - C_OPTS= -O3 -DLITTLE -traceback - LOADER_OPTS= -FR -O3 -Vaxlib -traceback -axP - C_LOADER_OPTS=-v -traceback + F_OPTS= -FR -O3 -recursive -unroll -static -traceback -axP + C_OPTS= -O3 -DLITTLE -static -traceback + LOADER_OPTS= -FR -O3 -unroll -traceback -axP + C_LOADER_OPTS=-v -static #---------------------------------------------------------------------------------------# endif #------------------------------------------------------------------------------------------# diff --git a/ED/build/bin/objects.mk b/ED/build/bin/objects.mk index 8c015676e..a2b8efdbf 100644 --- a/ED/build/bin/objects.mk +++ b/ED/build/bin/objects.mk @@ -12,6 +12,7 @@ OBJ_MODEL = \ allometry.o \ an_header.o \ average_utils.o \ + bdf2_solver.o \ budget_utils.o \ canopy_air_coms.o \ canopy_layer_coms.o \ @@ -22,6 +23,7 @@ OBJ_MODEL = \ consts_coms.o \ dateutils.o \ decomp_coms.o \ + detailed_coms.o \ disturbance.o \ disturb_coms.o \ edio.o \ @@ -71,6 +73,7 @@ OBJ_MODEL = \ hdf5_coms.o \ hdf5_utils.o \ heun_driver.o \ + hybrid_driver.o \ hydrology_coms.o \ hydrology_constants.o \ init_hydro_sites.o \ diff --git a/ED/build/bin/rules.mk b/ED/build/bin/rules.mk index 34c12d5f5..7e2ae688a 100644 --- a/ED/build/bin/rules.mk +++ b/ED/build/bin/rules.mk @@ -13,6 +13,11 @@ average_utils.o : $(ED_IO)/average_utils.f90 $(F90_COMMAND) $(= 0. - Minimum relative soil moisture above dry air of the top 75cm ! - ! that will prevent fires to happen. ! - ! < 0. - Minimum mean soil moisture potential in MPa of the top 75 cm ! - ! that will prevent fires to happen. The dry air soil ! - ! potential is defined as -3.1 MPa, so make sure SM_FIRE is ! - ! greater than this value. ! + ! INCLUDE_FIRE -- Which threshold to use for fires. ! + ! 0. No fires; ! + ! 1. (deprecated) Fire will be triggered with enough biomass and ! + ! integrated ground water depth less than a threshold. Based on ! + ! ED-1, the threshold assumes that the soil is 1 m, so deeper ! + ! soils will need to be much drier to allow fires to happen and ! + ! often will never allow fires. ! + ! 2. Fire will be triggered with enough biomass and the total soil ! + ! water at the top 75 cm falls below a threshold. ! + ! FIRE_PARAMETER -- If fire happens, this will control the intensity of the disturbance ! + ! given the amount of fuel (currently the total above-ground ! + ! biomass). ! + ! SM_FIRE -- This is used only when INCLUDE_FIRE = 2. The sign here matters. ! + ! >= 0. - Minimum relative soil moisture above dry air of the top 1m ! + ! that will prevent fires to happen. ! + ! < 0. - Minimum mean soil moisture potential in MPa of the top 1m ! + ! that will prevent fires to happen. The dry air soil ! + ! potential is defined as -3.1 MPa, so make sure SM_FIRE is ! + ! greater than this value. ! !---------------------------------------------------------------------------------------! NL%INCLUDE_FIRE = 2 - NL%SM_FIRE = 0.07 + NL%FIRE_PARAMETER = 0.2 + NL%SM_FIRE = -1.45 !---------------------------------------------------------------------------------------! @@ -988,7 +1012,7 @@ $ED_NL ! 4. Same as 0, but if finds the ground conductance following CLM ! ! technical note (equations 5.98-5.100). ! !---------------------------------------------------------------------------------------! - NL%ICANTURB = 4 + NL%ICANTURB = 2 !---------------------------------------------------------------------------------------! @@ -1066,7 +1090,7 @@ $ED_NL ! 2. Soil conductivity decreases with depth even for constant soil moisture ! ! , otherwise it is the same as 1. ! !---------------------------------------------------------------------------------------! - NL%IPERCOL = 1 + NL%IPERCOL = 0 !---------------------------------------------------------------------------------------! @@ -1114,30 +1138,33 @@ $ED_NL !---------------------------------------------------------------------------------------! ! The following variables control the size of sub-polygon structures in ED-2. ! - ! MAXSITE -- This is the strict maximum number of sites that each polygon can ! - ! contain. Currently this is used only when the user wants to run the ! - ! same polygon with multiple soil types. If there aren't that many ! - ! different soil types with a minimum area (check MIN_SITE_AREA ! - ! below), then the model will allocate just the amount needed. ! - ! MAXPATCH -- If number of patches in a given site exceeds MAXPATCH, force patch ! - ! fusion. If MAXPATCH is 0, then fusion will never happen. If ! - ! MAXPATCH is negative, then the absolute value is used only during ! - ! the initialization, and fusion will never happen again. Notice that ! - ! if the patches are too different, then the actual number of patches ! - ! in a site may exceed MAXPATCH. ! - ! MAXCOHORT -- If number of cohorts in a given patch exceeds MAXCOHORT, force ! - ! cohort fusion. If MAXCOHORT is 0, then fusion will never happen. ! - ! If MAXCOHORT is negative, then the absolute value is used only ! - ! during the initialization, and fusion will never happen again. ! - ! Notice that if the cohorts are too different, then the actual number ! - ! of cohorts in a patch may exceed MAXCOHORT. ! - ! MIN_SITE_AREA -- This is the minimum fraction area of a given soil type that allows a ! - ! site to be created (ignored if IED_INIT_MODE is set to 3). ! - !---------------------------------------------------------------------------------------! - NL%MAXSITE = 1 - NL%MAXPATCH = 20 - NL%MAXCOHORT = 80 - NL%MIN_SITE_AREA = 0.005 + ! MAXSITE -- This is the strict maximum number of sites that each polygon can ! + ! contain. Currently this is used only when the user wants to run ! + ! the same polygon with multiple soil types. If there aren't that ! + ! many different soil types with a minimum area (check MIN_SITE_AREA ! + ! below), then the model will allocate just the amount needed. ! + ! MAXPATCH -- If number of patches in a given site exceeds MAXPATCH, force patch ! + ! fusion. If MAXPATCH is 0, then fusion will never happen. If ! + ! MAXPATCH is negative, then the absolute value is used only during ! + ! the initialization, and fusion will never happen again. Notice ! + ! that if the patches are too different, then the actual number of ! + ! patches in a site may exceed MAXPATCH. ! + ! MAXCOHORT -- If number of cohorts in a given patch exceeds MAXCOHORT, force ! + ! cohort fusion. If MAXCOHORT is 0, then fusion will never happen. ! + ! If MAXCOHORT is negative, then the absolute value is used only ! + ! during the initialization, and fusion will never happen again. ! + ! Notice that if the cohorts are too different, then the actual ! + ! number of cohorts in a patch may exceed MAXCOHORT. ! + ! MIN_SITE_AREA -- This is the minimum fraction area of a given soil type that allows ! + ! a site to be created (ignored if IED_INIT_MODE is set to 3). ! + ! MIN_PATCH_AREA -- This is the minimum fraction area of a given soil type that allows ! + ! a site to be created (ignored if IED_INIT_MODE is set to 3). ! + !---------------------------------------------------------------------------------------! + NL%MAXSITE = 1 + NL%MAXPATCH = 20 + NL%MAXCOHORT = 80 + NL%MIN_SITE_AREA = 0.005 + NL%MIN_PATCH_AREA = 0.005 !---------------------------------------------------------------------------------------! @@ -1308,10 +1335,52 @@ $ED_NL + !---------------------------------------------------------------------------------------! + ! The following variables are used to control the detailed output for debugging ! + ! purposes. ! + ! ! + ! IDETAILED -- This flag controls the possible detailed outputs, mostly used for ! + ! debugging purposes. Notice that this doesn't replace the normal debug- ! + ! ger options, the idea is to provide detailed output to check bad ! + ! assumptions. The options are additive, and the indices below represent ! + ! the different types of output: ! + ! ! + ! 1 -- Detailed budget (every DTLSM) ! + ! 2 -- Detailed photosynthesis (every DTLSM) ! + ! 4 -- Detailed output from the integrator (every HDID) ! + ! 8 -- Thermodynamic bounds for sanity check (every DTLSM) ! + ! 16 -- Daily error stats (which variable caused the time step to shrink) ! + ! 32 -- Allometry parameters, and minimum and maximum sizes ! + ! (two files, only at the beginning) ! + ! ! + ! In case you don't want any detailed output (likely for most runs), set ! + ! IDETAILED to zero. In case you want to generate multiple outputs, add ! + ! the number of the sought options: for example, if you want detailed ! + ! photosynthesis and detailed output from the integrator, set IDETAILED ! + ! to 6 (2 + 4). Any combination of the above outputs is acceptable, al- ! + ! though all but the last produce a sheer amount of txt files, in which ! + ! case you may want to look at variable PATCH_KEEP. It is also a good ! + ! idea to set IVEGT_DYNAMICS to 0 when using the first five outputs. ! + ! ! + ! ! + ! PATCH_KEEP -- This option will eliminate all patches except one from the initial- ! + ! isation. This is only used when one of the first five types of ! + ! detailed output is active, otherwise it will be ignored. Options are: ! + ! -2. Keep only the patch with the lowest potential LAI ! + ! -1. Keep only the patch with the highest potential LAI ! + ! 0. Keep all patches. ! + ! > 0. Keep the patch with the provided index. In case the index is ! + ! not valid, the model will crash. ! + !---------------------------------------------------------------------------------------! + NL%IDETAILED = 0 + NL%PATCH_KEEP = 0 + !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! ! IOPTINPT -- Optimization configuration. (Currently not used) ! !---------------------------------------------------------------------------------------! - NL%IOPTINPT = '' + NL%IOPTINPT = '' !---------------------------------------------------------------------------------------! $END !==========================================================================================! diff --git a/ED/src/driver/ed_driver.f90 b/ED/src/driver/ed_driver.f90 index 6633a9e93..66d2950aa 100644 --- a/ED/src/driver/ed_driver.f90 +++ b/ED/src/driver/ed_driver.f90 @@ -22,7 +22,9 @@ subroutine ed_driver() , nnodetot & ! intent(in) , sendnum & ! intent(inout) , recvnum ! ! intent(in) - + use detailed_coms , only : idetailed & ! intent(in) + , patch_keep ! ! intent(in) + use phenology_aux , only : first_phenology ! ! subroutine implicit none !----- Included variables. -------------------------------------------------------------! include 'mpif.h' ! MPI commons @@ -36,6 +38,7 @@ subroutine ed_driver() real :: w1 real :: w2 real :: wtime_start + logical :: patch_detailed !----- External functions. -------------------------------------------------------------! real , external :: walltime ! wall time !---------------------------------------------------------------------------------------! @@ -138,13 +141,16 @@ subroutine ed_driver() end if !---------------------------------------------------------------------------------------! - ! TEMPORARY THING... We eliminate all patches but the one to be debugged. ! - ! Special cases: ! + ! In case the runs is going to produce detailed output, we eliminate all patches ! + ! but the one to be analysed in detail. Special cases: ! ! 0 -- Keep all patches. ! ! -1 -- Keep the one with the highest LAI ! ! -2 -- Keep the one with the lowest LAI ! !---------------------------------------------------------------------------------------! - !call exterminate_patches_except(-1) + patch_detailed = ibclr(idetailed,5) > 0 + if (patch_detailed) then + call exterminate_patches_except(patch_keep) + end if !---------------------------------------------------------------------------------------! @@ -418,7 +424,20 @@ subroutine exterminate_patches_except(keeppa) keepact = maxloc(csite%lai,dim=1) case default !----- Keep a fixed patch number. ------------------------------------------! - keepact = min(keeppa,csite%npatches) + keepact = keeppa + + if (keepact > csite%npatches) then + write(unit=*,fmt='(a)') '-----------------------------------------' + write(unit=*,fmt='(a,1x,i6)') ' - IPY = ',ipy + write(unit=*,fmt='(a,1x,i6)') ' - ISI = ',isi + write(unit=*,fmt='(a,1x,i6)') ' - NPATCHES = ',csite%npatches + write(unit=*,fmt='(a,1x,i6)') ' - KEEPPA = ',keeppa + write(unit=*,fmt='(a)') '-----------------------------------------' + call fail_whale ('KEEPPA can''t be greater than NPATCHES' & + ,'ed_driver.f90') + call fatal_error('KEEPPA can''t be greater than NPATCHES' & + ,'exterminate_patches_except','ed_driver.f90') + end if end select patchloop: do ipa=1,csite%npatches diff --git a/ED/src/driver/ed_met_driver.f90 b/ED/src/driver/ed_met_driver.f90 index 7b1eea9b0..0b1394366 100644 --- a/ED/src/driver/ed_met_driver.f90 +++ b/ED/src/driver/ed_met_driver.f90 @@ -804,31 +804,22 @@ subroutine update_met_drivers(cgrid) , dtlsm ! ! intent(in) use canopy_air_coms , only : ubmin ! ! intent(in) use canopy_radiation_coms, only : cosz_min ! ! intent(in) - use consts_coms , only : rdry & ! intent(in) - , cice & ! intent(in) - , cliq & ! intent(in) - , alli & ! intent(in) - , rocp & ! intent(in) - , p00 & ! intent(in) - , p00i & ! intent(in) - , cp & ! intent(in) - , cpi & ! intent(in) - , day_sec & ! intent(in) + use consts_coms , only : day_sec & ! intent(in) , t00 & ! intent(in) , t3ple & ! intent(in) , wdnsi & ! intent(in) , toodry & ! intent(in) - , tsupercool & ! intent(in) , pio180 & ! intent(in) , tiny_num ! ! intent(in) use pft_coms , only : include_pft & ! intent(in) , hgt_max ! ! intent(in) use ed_max_dims , only : n_pft ! ! intent(in) - use therm_lib , only : rslif & ! function + use therm_lib , only : tl2uint & ! function , ptrh2rvapil & ! function + , press2exner & ! function + , extemp2theta & ! function , thetaeiv & ! function - , rehuil & ! function - , qtk ! ! function + , rehuil ! ! function implicit none !----- Arguments -----------------------------------------------------------------------! @@ -849,20 +840,18 @@ subroutine update_met_drivers(cgrid) integer :: ipy integer :: isi integer :: ipft - real :: wnext - real :: wprev - real :: dtnext - real :: dtprev - real :: rvaux - real :: rvsat - real :: min_shv - real :: temp0 - real :: theta_prev - real :: theta_next - real :: relhum - real :: snden ! snow density (kg/m3) - real :: fice ! Ice fraction precipication - real :: fliq ! Liquid fraction precipitation + real(kind=4) :: wnext + real(kind=4) :: wprev + real(kind=4) :: dtnext + real(kind=4) :: dtprev + real(kind=4) :: rvaux + real(kind=4) :: rvsat + real(kind=4) :: min_shv + real(kind=4) :: temp0 + real(kind=4) :: relhum + real(kind=4) :: snden ! snow density (kg/m3) + real(kind=4) :: fice ! Ice fraction precipication + real(kind=4) :: fliq ! Liquid fraction precipitation real(kind=4) :: secz_prev ! Mean of sec(zenith angle) - previous real(kind=4) :: secz_next ! Mean of sec(zenith angle) - next real(kind=4) :: fperp_prev ! Perpendicular flux - previous @@ -1421,7 +1410,6 @@ subroutine update_met_drivers(cgrid) !---------------------------------------------------------------------------! do ipy = 1,cgrid%npolygons cgrid%met(ipy)%prss = cgrid%metinput(ipy)%pres(mprev) - cgrid%met(ipy)%exner = cp * (p00i * cgrid%met(ipy)%prss)**rocp end do case('hgt') !----- Air pressure. ------------------------------ [ m] -! @@ -1487,15 +1475,9 @@ subroutine update_met_drivers(cgrid) cgrid%met(ipy)%atm_shv = cgrid%metinput(ipy)%sh(mprev) end do - case('tmp') - !---------------------------------------------------------------------------! - ! The flag is given at the air temperature, but we use the flag for ! - ! potential temperature [ K] ! - !---------------------------------------------------------------------------! + case('tmp') !------ Air temperature. --------------------------- [ K] -! do ipy = 1,cgrid%npolygons - cgrid%met(ipy)%atm_theta = cgrid%metinput(ipy)%tmp(mprev) & - * (p00 / cgrid%metinput(ipy)%pres(mprev)) & - ** rocp + cgrid%met(ipy)%atm_tmp = cgrid%metinput(ipy)%tmp (mprev) end do case('co2') !----- CO2 mixing ratio. -------------------------- [ ppm] -! @@ -1629,7 +1611,6 @@ subroutine update_met_drivers(cgrid) do ipy = 1,cgrid%npolygons cgrid%met(ipy)%prss = cgrid%metinput(ipy)%pres(mnext) * wnext & + cgrid%metinput(ipy)%pres(mprev) * wprev - cgrid%met(ipy)%exner = cp * (p00i * cgrid%met(ipy)%prss)**rocp end do case('hgt') !----- Air pressure. ------------------------------ [ m] -! @@ -1692,22 +1673,11 @@ subroutine update_met_drivers(cgrid) + cgrid%metinput(ipy)%sh(mprev) * wprev end do - case('tmp') - - - !---------------------------------------------------------------------------! - ! The flag is given at the air temperature, but we use the flag for ! - ! potential temperature [ K] ! - !---------------------------------------------------------------------------! + case('tmp') !----- Air temperature ---------------------------- [ K] -! do ipy = 1,cgrid%npolygons - - theta_next = cgrid%metinput(ipy)%tmp(mnext) & - * (p00 / cgrid%metinput(ipy)%pres(mnext))** rocp - theta_prev = cgrid%metinput(ipy)%tmp(mprev) & - * (p00 / cgrid%metinput(ipy)%pres(mprev))** rocp - - !----- Interpolate potential temperature. -------------------------------! - cgrid%met(ipy)%atm_theta = theta_next * wnext + theta_prev * wprev + cgrid%met(ipy)%atm_tmp = cgrid%metinput(ipy)%tmp(mnext) * wnext & + + cgrid%metinput(ipy)%tmp(mprev) * wprev + !------------------------------------------------------------------------! end do case('nbdsf') !----- Near IR beam downward shortwave flux. ------ [ W/m²] -! @@ -2213,25 +2183,39 @@ subroutine update_met_drivers(cgrid) end select end do varloop end do formloop - - !---------------------------------------------------------------------------------------! - ! Change from velocity squared to velocity, and compute qpcpg and dpcpg. ! + + + + + !---------------------------------------------------------------------------------------! + ! Now that all variables from the met driver were read and updated, we update the ! + ! derived variables. ! !---------------------------------------------------------------------------------------! polyloop: do ipy = 1,cgrid%npolygons - - !----- CO2 --------------------------------------------------------------------------! + !----- CO2 (only if it hasn't been read). -------------------------------------------! if (.not. have_co2) cgrid%met(ipy)%atm_co2 = initial_co2 + !------------------------------------------------------------------------------------! + + !----- Set the default Exner function from pressure. --------------------------------! + cgrid%met(ipy)%exner = press2exner(cgrid%met(ipy)%prss) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Set default potential temperature from Exner function and air temperature. ! + !------------------------------------------------------------------------------------! + cgrid%met(ipy)%atm_theta = extemp2theta(cgrid%met(ipy)%exner,cgrid%met(ipy)%atm_tmp) + temp0 = cgrid%met(ipy)%atm_tmp + !------------------------------------------------------------------------------------! - !----- Adjust meteorological variables for simple climate scenarios. ----------------! - cgrid%met(ipy)%atm_tmp = cpi * cgrid%met(ipy)%atm_theta * cgrid%met(ipy)%exner - temp0 = cgrid%met(ipy)%atm_tmp - if (atm_tmp_intercept /= 0.0 .or. atm_tmp_slope /= 1.0) then cgrid%met(ipy)%atm_tmp = atm_tmp_intercept & + cgrid%met(ipy)%atm_tmp * atm_tmp_slope !----- We must update potential temperature too. ---------------------------------! - cgrid%met(ipy)%atm_theta = cp * cgrid%met(ipy)%atm_tmp / cgrid%met(ipy)%exner + cgrid%met(ipy)%atm_theta = extemp2theta( cgrid%met(ipy)%exner & + , cgrid%met(ipy)%atm_tmp ) + !---------------------------------------------------------------------------------! end if cgrid%met(ipy)%pcpg = max(0.0,prec_intercept + cgrid%met(ipy)%pcpg * prec_slope) !------------------------------------------------------------------------------------! @@ -2249,14 +2233,16 @@ subroutine update_met_drivers(cgrid) ! Update atm_shv so the relative humidity remains the same. We use the ! ! functions from therm_lib.f90 so it is consistent with the rest of the code. ! !---------------------------------------------------------------------------------! - !----- 1. Temporarily convert specific humidity to mixing ratio. -----------------! - rvaux = cgrid%met(ipy)%atm_shv / (1. - cgrid%met(ipy)%atm_shv) - !----- 2. Find relative humidity. ------------------------------------------------! - relhum = rehuil(cgrid%met(ipy)%prss,temp0,rvaux) - !----- 3. Find the equivalent relative humidity with the new temperature. --------! - rvaux = ptrh2rvapil(relhum,cgrid%met(ipy)%prss,cgrid%met(ipy)%atm_tmp) - !----- 4. Convert the mixing ratio back to specific humidity. --------------------! - cgrid%met(ipy)%atm_shv = rvaux / (1. + rvaux) + !----- 1. Find relative humidity. ------------------------------------------------! + relhum = rehuil( cgrid%met(ipy)%prss & + , temp0 & + , cgrid%met(ipy)%atm_shv & + , .true. ) + !----- 2. Find the equivalent relative humidity with the new temperature. --------! + cgrid%met(ipy)%atm_shv = ptrh2rvapil( relhum & + , cgrid%met(ipy)%prss & + , cgrid%met(ipy)%atm_tmp & + , .true. ) !---------------------------------------------------------------------------------! end if @@ -2267,27 +2253,34 @@ subroutine update_met_drivers(cgrid) ! ables atm_rhv_min and atm_rhv_max (from met_driver_coms.f90, and defined at the ! ! init_met_params subroutine in ed_params.f90). ! !------------------------------------------------------------------------------------! - rvaux = cgrid%met(ipy)%atm_shv / (1. - cgrid%met(ipy)%atm_shv) - relhum = rehuil(cgrid%met(ipy)%prss,cgrid%met(ipy)%atm_tmp,rvaux) + relhum = rehuil(cgrid%met(ipy)%prss,cgrid%met(ipy)%atm_tmp,cgrid%met(ipy)%atm_shv & + ,.true.) !------------------------------------------------------------------------------------! ! Check whether the relative humidity is off-bounds. If it is, then we re- ! ! calculate the mixing ratio and convert to specific humidity. ! !------------------------------------------------------------------------------------! if (relhum < atm_rhv_min) then - relhum = atm_rhv_min - rvaux = ptrh2rvapil(relhum,cgrid%met(ipy)%prss,cgrid%met(ipy)%atm_tmp) - cgrid%met(ipy)%atm_shv = rvaux / (1. + rvaux) + relhum = atm_rhv_min + cgrid%met(ipy)%atm_shv = ptrh2rvapil( relhum & + , cgrid%met(ipy)%prss & + , cgrid%met(ipy)%atm_tmp & + , .true. ) elseif (relhum > atm_rhv_max) then - relhum = atm_rhv_max - rvaux = ptrh2rvapil(relhum,cgrid%met(ipy)%prss,cgrid%met(ipy)%atm_tmp) - cgrid%met(ipy)%atm_shv = rvaux / (1. + rvaux) + relhum = atm_rhv_max + cgrid%met(ipy)%atm_shv = ptrh2rvapil( relhum & + , cgrid%met(ipy)%prss & + , cgrid%met(ipy)%atm_tmp & + , .true. ) end if !------------------------------------------------------------------------------------! ! We now find the equivalent potential temperature. ! !------------------------------------------------------------------------------------! + rvaux = cgrid%met(ipy)%atm_shv / (1.0 - cgrid%met(ipy)%atm_shv) cgrid%met(ipy)%atm_theiv = thetaeiv(cgrid%met(ipy)%atm_theta,cgrid%met(ipy)%prss & - ,cgrid%met(ipy)%atm_tmp,rvaux,rvaux,1) + ,cgrid%met(ipy)%atm_tmp,rvaux,rvaux) + !------------------------------------------------------------------------------------! + !------ Apply met to sites, and adjust met variables for topography. ----------------! call calc_met_lapse(cgrid,ipy) @@ -2314,8 +2307,12 @@ subroutine update_met_drivers(cgrid) ! temperature, so it will respect the ideal gas law and first law of thermo- ! ! dynamics. ! !---------------------------------------------------------------------------------! - cpoly%met(isi)%exner = cp * (p00i * cpoly%met(isi)%prss) **rocp - cpoly%met(isi)%atm_theta = cp * cpoly%met(isi)%atm_tmp / cpoly%met(isi)%exner + cpoly%met(isi)%exner = press2exner(cpoly%met(isi)%prss) + cpoly%met(isi)%atm_theta = extemp2theta( cpoly%met(isi)%exner & + , cpoly%met(isi)%atm_tmp ) + !---------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------! ! Check the relative humidity associated with the current pressure, temper- ! @@ -2323,25 +2320,30 @@ subroutine update_met_drivers(cgrid) ! the variables atm_rhv_min and atm_rhv_max (from met_driver_coms.f90, and ! ! defined at the init_met_params subroutine in ed_params.f90). ! !---------------------------------------------------------------------------------! - rvaux = cpoly%met(isi)%atm_shv / (1. - cpoly%met(isi)%atm_shv) - relhum = rehuil(cpoly%met(isi)%prss,cpoly%met(isi)%atm_tmp,rvaux) + relhum = rehuil(cpoly%met(isi)%prss,cpoly%met(isi)%atm_tmp,cpoly%met(isi)%atm_shv & + ,.true.) !---------------------------------------------------------------------------------! ! Check whether the relative humidity is off-bounds. If it is, then we re- ! ! calculate the mixing ratio and convert to specific humidity. ! !---------------------------------------------------------------------------------! if (relhum < atm_rhv_min) then relhum = atm_rhv_min - rvaux = ptrh2rvapil(relhum,cpoly%met(isi)%prss,cpoly%met(isi)%atm_tmp) - cpoly%met(isi)%atm_shv = rvaux / (1. + rvaux) + cpoly%met(isi)%atm_shv = ptrh2rvapil( relhum & + , cgrid%met(ipy)%prss & + , cgrid%met(ipy)%atm_tmp & + , .true. ) elseif (relhum > atm_rhv_max) then - relhum = atm_rhv_max - rvaux = ptrh2rvapil(relhum,cpoly%met(isi)%prss,cpoly%met(isi)%atm_tmp) - cpoly%met(isi)%atm_shv = rvaux / (1. + rvaux) + relhum = atm_rhv_max + cpoly%met(isi)%atm_shv = ptrh2rvapil( relhum & + , cgrid%met(ipy)%prss & + , cgrid%met(ipy)%atm_tmp & + , .true. ) end if !----- Find the atmospheric equivalent potential temperature. --------------------! + rvaux = cgrid%met(ipy)%atm_shv / (1.0 - cgrid%met(ipy)%atm_shv) cpoly%met(isi)%atm_theiv = thetaeiv(cpoly%met(isi)%atm_theta,cpoly%met(isi)%prss & - ,cpoly%met(isi)%atm_tmp,rvaux,rvaux,2) + ,cpoly%met(isi)%atm_tmp,rvaux,rvaux) !----- Solar radiation -----------------------------------------------------------! cpoly%met(isi)%rshort_diffuse = cpoly%met(isi)%par_diffuse & @@ -2407,15 +2409,14 @@ subroutine update_met_drivers(cgrid) ! point) multiplied by the ice fraction. ! !---------------------------------------------------------------------------------! cpoly%met(isi)%qpcpg = max(0.0, cpoly%met(isi)%pcpg) & - * ( (1.0-fice) * cliq * ( max(t3ple,cpoly%met(isi)%atm_tmp) & - - tsupercool) & - + fice * cice * min(cpoly%met(isi)%atm_tmp,t3ple)) + * ( (1.0-fice) & + * tl2uint(max(t3ple,cpoly%met(isi)%atm_tmp),1.0) & + + fice * tl2uint(min(t3ple,cpoly%met(isi)%atm_tmp),0.0) ) !---------------------------------------------------------------------------------! - - end do siteloop - + !------------------------------------------------------------------------------------! end do polyloop + !---------------------------------------------------------------------------------------! return end subroutine update_met_drivers diff --git a/ED/src/driver/ed_model.f90 b/ED/src/driver/ed_model.f90 index df91e6cda..d18c4a5f7 100644 --- a/ED/src/driver/ed_model.f90 +++ b/ED/src/driver/ed_model.f90 @@ -58,7 +58,6 @@ subroutine ed_model() , reset_integ_err ! ! subroutine use ed_node_coms , only : mynum & ! intent(in) , nnodetot ! ! intent(in) - use disturb_coms , only : include_fire ! ! intent(in) use mem_polygons , only : n_ed_region & ! intent(in) , n_poi & ! intent(in) , maxpatch & ! intent(in) @@ -262,6 +261,10 @@ subroutine ed_model() do ifm=1,ngrids call heun_timestep(edgrid_g(ifm)) end do + case (3) + do ifm=1,ngrids + call hybrid_timestep(edgrid_g(ifm)) + end do end select !------------------------------------------------------------------------------------! diff --git a/ED/src/dynamics/bdf2_solver.f90 b/ED/src/dynamics/bdf2_solver.f90 new file mode 100644 index 000000000..8a5be7b86 --- /dev/null +++ b/ED/src/dynamics/bdf2_solver.f90 @@ -0,0 +1,867 @@ +!============================================================================== +! Driver and core for numerically integrating the canopy via BDF2 +! BDF2 is a trapezoidal split step method (backward and forward) +! +! To solve for the next step, we must solve a set of linear equations +! using data on the current and previous step. +! +! U_{n+1} = [4U_{n}+U_{n-1}][3I-2dtA]^{-1} +! +! The crux of this method is solving the for the instantaneous derivatives +! dU/dt = A*U_{n+1} + B (where B is a forcing like SW radiation +! energy flux from the ABL, or energy flux +! from the ground. The mass and energy +! flux from the ground is solved elsewhere +! +! One difficulty in creating the A matrix, is that some of these processes +! are nearly binary...is there ponded water or not at the next step. +! Therefore, it may be necessary to to a sanity check on the existence of +! surface water and test to see if it was correct at the end of the step. +! +!============================================================================== + +subroutine bdf2_solver(cpatch,yprev,ycurr,ynext,dydt,nstate,dtf,dtb) + + use grid_coms,only : nzg,nzs + use rk4_coms,only : effarea_evap,effarea_heat,effarea_transp, & + rk4site,rk4patchtype,bdf2patchtype,checkbudget,hcapcan + use ed_misc_coms,only : fast_diagnostics + use ed_state_vars,only : patchtype + use therm_lib8,only : reducedpress8,idealdenssh8 + use ed_therm_lib,only : ed_grndvap8 + use consts_coms,only : cpdry8,p00i8,rdry8, & + rocv8,cpocv8,cliq8,cice8,rocp8,cpocv,epim1, & + alli8,t3ple8,alvi38,wdns8,cph2o8,tsupercool_liq8,pi18 + use therm_lib8,only : uint2tl8,uextcm2tl8,tq2enthalpy8, tl2uint8 + use soil_coms, only : soil8,dslz8 + + implicit none + + ! define the previous,current and next patch states + integer,intent(in) :: nstate + real(kind=8),dimension(nstate) :: Y + real(kind=8),dimension(nstate) :: Yf + real(kind=8),dimension(nstate,nstate) :: A + real(kind=8),dimension(nstate) :: B + real,dimension(nstate,nstate) :: IA + type(patchtype),target :: cpatch + type(bdf2patchtype), target :: yprev + type(rk4patchtype), target :: ycurr + type(rk4patchtype), target :: ynext + type(rk4patchtype), target :: dydt + integer,dimension(nstate) :: indx + real(kind=8),intent(in) :: dtf ! dt for n -> n+1 + real(kind=8),intent(in) :: dtb ! dt for n -> n-1 +! real(kind=8),intent(in) :: can_depth + + integer :: id_tcan,id_tveg,ico + integer :: k,ksn + integer :: i,j + real(kind=8) :: shctop + real(kind=8) :: rhoc ! canopy air density [kg/m3] + real(kind=8) :: dc ! canopy depth [m] + real(kind=8) :: qc ! canopy spec. hum [kg/kg] + real(kind=8) :: Tg ! soil temperature [K] + real(kind=8) :: gg ! ground-can conductivity [m/s] + real(kind=8) :: mgc ! mass flux ground->can [kg/s/m2] + real(kind=8) :: ga ! atm-canopy conductivity [m/s] + real(kind=8) :: Ta ! atm temperature [K] + real(kind=8) :: mac ! mass flux atm->can [kg/s/m2] + real(kind=8) :: dqcdt ! time partial of qc [kg/kg/s] + real(kind=8) :: xc ! lumped term (canopy) [-] + real(kind=8) :: href ! reference spec. enth. [J/kg] + real(kind=8) :: gv ! veg-canopy conductivity [m/s] + real(kind=8) :: hfa ! effective area of heat flux [m2/m2] + real(kind=8) :: mlc ! mass flux leaf->can [kg/m2/s] + real(kind=8) :: mwc ! mass flux wood->can + real(kind=8) :: mtr ! mass flux transp veg->can [kg/m2/s] + real(kind=8) :: fliq ! liquid fraction leaf surf [kg/kg] + real(kind=8) :: qv ! water mass on vegetation [kg/m2] + real(kind=8) :: dqvdt ! time partial of qv [kg/m2/s] + real(kind=8) :: xv ! lumped term (vegetation) + + real(kind=8) :: eflxac + real(kind=8) :: qwflxgc + real(kind=8) :: qwflxac + real(kind=8) :: hflxac + real(kind=8) :: qwflxlc,qwflxlc_tot + real(kind=8) :: qwflxwc,qwflxwc_tot + real(kind=8) :: qtransp,qtransp_tot + real(kind=8) :: hflxlc,hflxlc_tot + real(kind=8) :: hflxwc,hflxwc_tot + + + !==========================================================================! + ! ! + ! Part 1: Build the forecasted transition matrix A ! + ! ! + ! Assume that Y takes the following form ! + ! Y = [ T_can T_veg1 T_veg2 ... T_vegN ] ! + ! ! + !==========================================================================! + + !==========================================================================! + ! Row and Column indices for the transition matrix operators ! + !==========================================================================! + id_tcan = 1 + + + !==========================================================================! + ! Heat flux to the atmosphere... few ways to go about this ! + ! 1) use the heat flux at step time n ! + ! 2) use atmospheric temp at step n, but incorporate the canopy temp at n+1! + ! to calculate flux, uses conductivity at n ! + ! 3) use forward time step of atmospheric temp as well (a little overboard)! + ! 4) also would use the forward euler canopy and leaf temps to recalc ! + ! aerodynamic conductances ! + ! **** Using method 2 right now ! + !==========================================================================! + + !--------------------------------------------------------------------------! + ! Ground Temp is estimated via an explicit method, it represents ! + ! the effective ground surface temperature, be it standing water ! + ! or moist/dry soil ! + !--------------------------------------------------------------------------! + +! ksn=0 +! do k=1,ycurr%nlev_sfcwater +! if(ycurr%sfcwater_mass(k)>1.d-5)ksn=k +! end do + + shctop = soil8(rk4site%ntext_soil(nzg))%slcpd + call uextcm2tl8(ynext%soil_energy(nzg),ynext%soil_water(nzg)*wdns8,shctop & + ,ynext%soil_tempk(nzg),ynext%soil_fracliq(nzg)) + + ksn=ycurr%nlev_sfcwater + if (ksn>0) then + call uint2tl8(ycurr%sfcwater_energy(ksn)/ycurr%sfcwater_mass(ksn), & + ycurr%sfcwater_tempk(ksn),ycurr%sfcwater_fracliq(ksn)) + endif + + + k=max(1,ksn) + + call ed_grndvap8(ksn,ynext%soil_water(nzg),ynext%soil_tempk(nzg) & + ,ynext%soil_fracliq(nzg),ycurr%sfcwater_tempk(k) & + ,ycurr%sfcwater_fracliq(k),ycurr%can_prss,ynext%can_shv & + ,ynext%ground_shv,ynext%ground_ssh,ynext%ground_temp & + ,ynext%ground_fliq,ynext%ggsoil) + + + + + !----- Initialize the matrices used for the linear operations -------------! + + A = 0.d0 + B = 0.d0 + Y = 0.d0 + + + !----- Set temporary variables used for readability -----------------------! + + rhoc = ycurr%can_rhos + dc = ycurr%can_depth + qc = ynext%can_shv + Tg = ycurr%ground_temp + gg = ycurr%ggnet + mgc = ycurr%wflxgc + ga = ycurr%ggbare + Ta = rk4site%atm_theta*rk4site%atm_exner/cpdry8 + mac = ycurr%wflxac + dqcdt = dydt%can_shv + xc = rhoc*dc*((1.d0-qc)*cpdry8+qc*cph2o8) + href = t3ple8*cice8+alvi38-cph2o8*t3ple8 + + + ! USES NEW TG +!! B(id_tcan) = (1.d0/xc)* & +!! (gg*rhoc*cpdry8*Tg & +!! + mgc*(href+cph2o8*Tg) & +!! + ga*rhoc*cpdry8*Ta & +!! + mac*href & +!! + mac*cph2o8*0.5d0*Ta & +!! + sum(ycurr%wflxlc)*href & +!! + sum(ycurr%wflxtr)*href & +!! + sum(ycurr%wflxwc)*href & +!! - dc*rhoc*href*dqcdt) + + ! USES ycurr HFLXGC + B(id_tcan) = (1.d0/xc)* & + (gg*rhoc*cpdry8*(ycurr%ground_temp-ycurr%can_temp) & + + mgc*(href+cph2o8*Tg) & + + ga*rhoc*cpdry8*Ta & + + mac*href & + + mac*cph2o8*0.5d0*Ta & + + sum(ycurr%wflxlc)*href & + + sum(ycurr%wflxtr)*href & + + sum(ycurr%wflxwc)*href & + - dc*rhoc*href*dqcdt) + + + + ! USES NEW TG +!! A(id_tcan,id_tcan) = (1.d0/xc)* & +!! (-gg*rhoc*cpdry8 & +!! -ga*rhoc*cpdry8 & +!! +0.5d0*mac*cph2o8) & +!! -(dqcdt*dc*rhoc/(xc**2.d0))* & +!! ((1.d0-qc)*cpdry8 + qc*cph2o8)*(cph2o8-cpdry8) + + ! USES ycurr HFLXGC + A(id_tcan,id_tcan) = (1.d0/xc)* & + (-ga*rhoc*cpdry8 & + +0.5d0*mac*cph2o8) & + -(dqcdt*dc*rhoc/(xc**2.d0))* & + ((1.d0-qc)*cpdry8 + qc*cph2o8)*(cph2o8-cpdry8) + + + + + Y(id_tcan) = (3.d0+(dtf/dtb))*ycurr%can_temp - & + (dtf/dtb)*yprev%can_temp + 2.d0*B(id_tcan)*dtf + + + !===========================================================================! + ! Derivatives associated with vegetation <-> canopy-air fluxes + !===========================================================================! + + id_tveg = id_tcan + + do ico=1,cpatch%ncohorts + + if (ycurr%leaf_resolvable(ico)) then + + id_tveg = id_tveg+1 + + gv = ycurr%leaf_gbh(ico)/(ycurr%can_rhos*cpdry8) + hfa = effarea_heat*ycurr%lai(ico) + mlc = ycurr%wflxlc(ico) + mtr = ycurr%wflxtr(ico) + fliq = ycurr%leaf_fliq(ico) + qv = ynext%leaf_water(ico) + dqvdt= dydt%leaf_water(ico) + + xv = fliq*cliq8*qv + (1.d0-fliq)*cice8*qv + ycurr%leaf_hcap(ico) + + + + ! dTc/dt ~ Tc) + A(id_tcan,id_tcan) = A(id_tcan,id_tcan) - gv*hfa*rhoc*cpdry8/xc + + ! A(dTc/dt ~ Tv) + A(id_tcan,id_tveg) = A(id_tcan,id_tveg) & + + (1.d0/xc)*(gv*hfa*rhoc*cpdry8 + mlc*cph2o8 + mtr*cph2o8) + + + ! Note hflx_lrsti is rshort+rlong+Htrans(soil)+Hint-Hshed + + ! B(dTv/dt) + B(id_tveg) = (1.d0/xv)* & + (ycurr%hflx_lrsti(ico) & + - href*mlc & + - href*mtr & + + (fliq*cliq8*t3ple8 - fliq*cice8*t3ple8 - fliq*alli8)*dqvdt) + + + ! A(dTv/dt ~ Tc) + A(id_tveg,id_tcan) = A(id_tveg,id_tcan) + & + (hfa*gv*rhoc*cpdry8)/xv + + + ! A(dTv/dt ~ Tv) + A(id_tveg,id_tveg) = A(id_tveg,id_tveg) + & + (1.d0/xv)*( (fliq*cice8 - fliq*cliq8 - cice8)*dqvdt & + - hfa*rhoc*gv*cpdry8 - (mlc+mtr)*cph2o8) + + + Y(id_tveg) = (3.d0+dtf/dtb)*ycurr%leaf_temp(ico) - & + (dtf/dtb)*yprev%leaf_temp(ico) + & + 2.d0*B(id_tveg)*dtf + + + end if + + end do + + ! ======================= WOOD ==========================! + ! If we have yet to do wood temps, do another loop + ! ========================================================! + + if( id_tveg < nstate) then + + do ico=1,cpatch%ncohorts + + if (ycurr%wood_resolvable(ico)) then + + id_tveg = id_tveg+1 + + gv = ycurr%wood_gbh(ico)/(ycurr%can_rhos*cpdry8) + hfa = pi18*ycurr%wai(ico) + mlc = ycurr%wflxwc(ico) + mtr = 0.d0 + fliq = ycurr%wood_fliq(ico) + qv = ynext%wood_water(ico) + dqvdt= dydt%wood_water(ico) + + xv = fliq*cliq8*qv + (1.d0-fliq)*cice8*qv + ycurr%wood_hcap(ico) + + ! dTc/dt ~ Tc) + A(id_tcan,id_tcan) = A(id_tcan,id_tcan) - gv*hfa*rhoc*cpdry8/xc + + ! A(dTc/dt ~ Tv) + A(id_tcan,id_tveg) = A(id_tcan,id_tveg) & + + (1.d0/xc)*(gv*hfa*rhoc*cpdry8 + mlc*cph2o8 + mtr*cph2o8) + + + ! Note hflx_wrsti is rshort+rlong+Hint-Hshed + + ! B(dTv/dt) + B(id_tveg) = (1.d0/xv)* & + (ycurr%hflx_wrsti(ico) & + - href*mlc & + - href*mtr & + + (fliq*cliq8*t3ple8 - fliq*cice8*t3ple8 - fliq*alli8)*dqvdt) + + + ! A(dTv/dt ~ Tc) + A(id_tveg,id_tcan) = A(id_tveg,id_tcan) + & + (hfa*gv*rhoc*cpdry8)/xv + + + ! A(dTv/dt ~ Tv) + A(id_tveg,id_tveg) = A(id_tveg,id_tveg) + & + (1.d0/xv)*( (fliq*cice8 - fliq*cliq8 - cice8)*dqvdt & + - hfa*rhoc*gv*cpdry8 - (mlc+mtr)*cph2o8) + + + Y(id_tveg) = (3.d0+dtf/dtb)*ycurr%leaf_temp(ico) - & + (dtf/dtb)*yprev%wood_temp(ico) + & + 2.d0*B(id_tveg)*dtf + + end if + + + end do + end if + + + ! Create the matrix [3I-2Adt] + ! And create the upper portion of the equation [4U_{n}+U_{n-1}+2Bdt] + + do i=1,nstate + do j=1,nstate + A(i,j)=-A(i,j)*2.d0*dtf + end do + A(i,i) = 3.d0+A(i,i) + end do + + + call selective_gaussian_2body(A,Yf,Y,nstate) + + Y=Yf + + ! ------------------------------------------------------------------------! + ! Set the leaf and canopy temepratures in the memory buffer (rk4type) ! + ! Update vars that otherwise would not have been diagnostic if we were ! + ! using a different scheme. For instance, rk4 and forward euler use ! + ! can_enthalpy + !-------------------------------------------------------------------------! + + ! Send the canopy and leaf temperatures to the forward + ! Be sure to update leaf_energy and canopy ln-theta + + + ynext%can_temp = Y(1) + ynext%can_enthalpy = (1.d0-qc)*cpdry8*Y(1) + qc*(href + cph2o8*Y(1)) + + + ! ------------------------------------------------------------------------! + ! Note: Significant assumption being made here. The partial derivative ! + ! of the leaf and wood temperature assumed that phase was constant. ! + ! This is true unless of course the water starts oscillating around the ! + ! freezing point. This solver will assume the veg system will heat and ! + ! cool without phase change, which of course is not true, but nothing is ! + ! perfect, so deal with it. AFter ynext%leaf_Temp crosses t3ple8, it will! + ! change the liquid fraction to either 0 or 1 depending on the direction ! + ! of change. ! + ! One possible alternative, is to determine the change in energy assuming ! + ! no phase change, and then apply that energy to the phase change at the ! + ! triple point. If the change in energy is less than phase change, set ! + ! the ynext temp to t3ple and linearly scale the liquid fraction. ! + ! ------------------------------------------------------------------------! + + qwflxlc_tot = 0.d0 + qtransp_tot = 0.d0 + hflxlc_tot = 0.d0 + + + id_tveg=1 + do ico=1,cpatch%ncohorts + if (ycurr%leaf_resolvable(ico)) then + + id_tveg=id_tveg+1 + + ynext%leaf_temp(ico) = Y(id_tveg) + if(ynext%leaf_temp(ico) < t3ple8) then + ynext%leaf_fliq(ico) = 0.d0 + ynext%leaf_energy(ico) = & + ynext%leaf_water(ico)*cice8*ynext%leaf_temp(ico) +& + ynext%leaf_temp(ico)*ycurr%leaf_hcap(ico) + else + ynext%leaf_fliq(ico) = 1.d0 + ynext%leaf_energy(ico) = ynext%leaf_temp(ico)* & + (ycurr%leaf_hcap(ico)+ynext%leaf_water(ico)*cliq8) - & + ynext%leaf_water(ico)*cliq8*tsupercool_liq8 + end if + + ! Back calculate the latent and sensible heat fluxes of leaves + ! ======================================================================== + + ! First calculate the effective qflxlc + qwflxlc = ycurr%wflxlc(ico)*tq2enthalpy8(ycurr%leaf_temp(ico),1.d0,.true.) + + ! Then effective transpiraiton + qtransp = ycurr%wflxtr(ico)*tq2enthalpy8(ycurr%leaf_temp(ico),1.d0,.true.) + + ! Use the resulting change in leaf energy to back-caculate what heat + ! flux would had been + hflxlc = ycurr%hflx_lrsti(ico) - qwflxlc - qtransp - & + (ynext%leaf_energy(ico)-ycurr%leaf_energy(ico))/dtf + + qwflxlc_tot = qwflxlc_tot + qwflxlc + qtransp_tot = qtransp_tot + qtransp + hflxlc_tot = hflxlc_tot + hflxlc + + end if + end do + + if( id_tveg < nstate) then + do ico=1,cpatch%ncohorts + if (ycurr%wood_resolvable(ico)) then + + id_tveg=id_tveg+1 + + ynext%wood_temp(ico) = Y(id_tveg) + if(ynext%wood_temp(ico) < t3ple8) then + ynext%wood_fliq(ico) = 0.d0 + ynext%wood_energy(ico) = & + ynext%wood_water(ico)*cice8*ynext%wood_temp(ico) +& + ynext%wood_temp(ico)*ycurr%wood_hcap(ico) + else + ynext%wood_fliq(ico) = 1.d0 + ynext%wood_energy(ico) = ynext%wood_temp(ico)* & + (ycurr%wood_hcap(ico)+ynext%wood_water(ico)*cliq8) - & + ynext%wood_water(ico)*cliq8*tsupercool_liq8 + end if + + + ! Back calculate the latent and sensible heat fluxes of leaves + ! ======================================================================== + + ! First calculate the effective qflxwc + qwflxwc = ycurr%wflxwc(ico)*tq2enthalpy8(ycurr%wood_temp(ico),1.d0,.true.) + + ! Use the resulting change in wood energy to back-caculate what heat + ! flux would had been + hflxwc = ycurr%hflx_wrsti(ico) - qwflxwc - & + (ynext%wood_energy(ico)-ycurr%wood_energy(ico))/dtf + + qwflxwc_tot = qwflxwc_tot + qwflxwc + hflxwc_tot = hflxwc_tot + hflxwc + + + + end if + end do + end if + + + !!!! =========================================================== + !!!! THIS SCHEME IS NOT UPDATING PRINT DETAILED FLUXES BETWEEN + !!!! LEAVES/WOOD WITH CANOPY AIR + !!!! =========================================================== + + + + + ! Update eulerian based budget fluxes + ! ============================================================ + + qwflxgc = ycurr%wflxgc * tq2enthalpy8(ycurr%ground_temp,1.d0,.true.) + + + eflxac = hcapcan*(ynext%can_enthalpy-ycurr%can_enthalpy)/dtf - & + (dydt%avg_sensible_gc + qwflxgc + & + hflxlc_tot + qwflxlc_tot + qtransp_tot + hflxwc_tot + qwflxwc_tot) + + + qwflxac = ycurr%wflxac * tq2enthalpy8(0.5*(ycurr%can_temp+Ta),1.d0,.true.) + + hflxac = eflxac-qwflxac + + + if(checkbudget)then + + ! Remove the previous integration + ynext%ebudget_loss2atm = ynext%ebudget_loss2atm - & + dydt%ebudget_loss2atm*dtf + + + ! Add the new integration + dydt%ebudget_loss2atm = -eflxac + ynext%ebudget_loss2atm = ynext%ebudget_loss2atm - eflxac*dtf + + end if + + if (fast_diagnostics .or. checkbudget ) then + + ! Update the sensible heat flux diagnostic + ynext%avg_sensible_ac = ynext%avg_sensible_ac - dydt%avg_sensible_ac*dtf + ynext%avg_sensible_ac = ynext%avg_sensible_ac + (hflxac)*dtf + + + end if + + + ! Make corrections to sensible heat flux and tstar + ! ====================================================== + + ! Remove the previous increment + ynext%tpwp = ynext%tpwp-dydt%tpwp*dtf + ynext%avg_tstar = ynext%avg_tstar-dydt%tstar*dtf + + + ! Make the current increment + ynext%avg_tstar = ynext%tstar + & + dtf*(hflxac/(rhoc*ycurr%ustar*ycurr%can_exner)) + + + ynext%tpwp = ynext%tpwp -(hflxac/(rhoc*ycurr%can_exner))*dtf + + + + + return +end subroutine bdf2_solver + +!================================================================ + +subroutine selective_gaussian_2body(ad,yd,xd,np) + + implicit none + + integer, intent(in) :: np + real(kind=8), dimension(np),intent(out) :: yd + real(kind=8), dimension(np,np),intent(in) :: ad + real(kind=8), dimension(np),intent(in) :: xd + real(kind=8) :: ydl + integer :: i + + + + if (np>1) then + + yd(1) = xd(1) + ydl = ad(1,1) + + do i=2,np + yd(1) = yd(1)-ad(1,i)*xd(i)/ad(i,i) + ydl = ydl-ad(1,i)*ad(i,1)/ad(i,i) + end do + + ! Solved the first term by gaussian substitution + yd(1) = yd(1)/ydl + + ! Now do the remaining terms + + do i=2,np + yd(i) = (xd(i)-ad(i,1)*yd(1))/ad(i,i) + end do + + else + + ! Trivial solution, no cohorts + + yd(1) = xd(1)/ad(1,1) + + end if + + + + return +end subroutine selective_gaussian_2body + +!================================================================ + + +subroutine ludcmp_dble(ad,n,np,indx,d) + + implicit none + + real(kind=8), parameter :: tiny_offset = 1.0d-32 + integer, intent(in) :: n + integer, intent(in) :: np + real, intent(out) :: d +! real, (kind=8),dimension(np,np), intent(inout) :: a + real(kind=8), dimension(np,np),intent(inout) :: ad + integer, dimension(n), intent(out) :: indx + real(kind=8), dimension(np) :: vv + integer :: i + integer :: j + integer :: k + integer :: imax + real(kind=8) :: sum + real(kind=8) :: aamax + real(kind=8) :: dum + +! ad = dble(a) + + d = 1.0 + + do i = 1, n + aamax = 0.0d0 + do j = 1, n + if(abs(ad(i,j)) > aamax)aamax = abs(ad(i,j)) + enddo + if(aamax == 0.0d0)then + print*,'singular matrix in ludcmp' + do j=1,n + print*,i,j,abs(ad(i,j)),aamax + enddo + stop + endif + vv(i) = 1.0d0 / aamax + enddo + + do j = 1, n + if(j.gt.1)then + do i = 1, j - 1 + sum = ad(i,j) + if(i > 1)then + do k = 1, i - 1 + sum = sum - ad(i,k) * ad(k,j) + enddo + ad(i,j) = sum + endif + enddo + endif + aamax = 0.0d0 + do i=j,n + sum = ad(i,j) + if (j > 1)then + do k = 1, j - 1 + sum = sum - ad(i,k) * ad(k,j) + enddo + ad(i,j) = sum + endif + dum = vv(i) * abs(sum) + if(dum >= aamax)then + imax = i + aamax = dum + endif + enddo + if(j /= imax)then + do k = 1, n + dum = ad(imax,k) + ad(imax,k) = ad(j,k) + ad(j,k) = dum + enddo + d = -d + vv(imax) = vv(j) + endif + indx(j) = imax + if(j /= n)then + if(ad(j,j) == 0.0d0) ad(j,j) = tiny_offset + dum = 1.0d0 / ad(j,j) + do i = j + 1, n + ad(i,j) = ad(i,j) * dum + enddo + endif + enddo + if(ad(n,n) == 0.0d0)ad(n,n) = tiny_offset + +! a = real(ad) + + return +end subroutine ludcmp_dble + +!============================================================= + +subroutine lubksb_dble(ad,n,np,indx,bd) + implicit none + integer, intent(in) :: n + integer, intent(in) :: np + integer, dimension(n), intent(in) :: indx +! real(, dimension(n), intent(inout) :: b + real(kind=8), dimension(n),intent(inout) :: bd +! real(kind=8), dimension(np,np), intent(in) :: a + real(kind=8), dimension(np,np),intent(in) :: ad + integer :: ii + integer :: i + integer :: ll + real(kind=8) :: sum + integer :: j + +! ad = dble(a) +! bd = dble(b) + + ii = 0 + do i=1,n + ll = indx(i) + sum = bd(ll) + bd(ll) = bd(i) + if(ii /= 0)then + do j=ii,i-1 + sum = sum - ad(i,j) * bd(j) + enddo + elseif(sum /= 0.0d0)then + ii = i + endif + bd(i) = sum + enddo + do i=n,1,-1 + sum = bd(i) + if ( i < n )then + do j=i+1,n + sum = sum - ad(i,j) * bd(j) + enddo + endif + bd(i) = sum / ad(i,i) + enddo + +! b = real(bd) + + return +end subroutine lubksb_dble + + + +! Updated 10/24/2001. +! +!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! ! +! Please Note: ! +! ! +! (1) This computer program is written by Tao Pang in conjunction with ! +! his book, "An Introduction to Computational Physics," published ! +! by Cambridge University Press in 1997. ! +! ! +! (2) No warranties, express or implied, are made for this program. ! +! ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +SUBROUTINE MIGS (A,N,X,INDX) +! +! Subroutine to invert matrix A(N,N) with the inverse stored +! in X(N,N) in the output. Copyright (c) Tao Pang 2001. +! + IMPLICIT NONE + INTEGER, INTENT (IN) :: N + INTEGER :: I,J,K + INTEGER, INTENT (OUT), DIMENSION (N) :: INDX + REAL, INTENT (INOUT), DIMENSION (N,N):: A + REAL, INTENT (OUT), DIMENSION (N,N):: X + REAL, DIMENSION (N,N) :: B +! + DO I = 1, N + DO J = 1, N + B(I,J) = 0.0 + END DO + END DO + DO I = 1, N + B(I,I) = 1.0 + END DO +! + CALL ELGS (A,N,INDX) +! + DO I = 1, N-1 + DO J = I+1, N + DO K = 1, N + B(INDX(J),K) = B(INDX(J),K)-A(INDX(J),I)*B(INDX(I),K) + END DO + END DO + END DO +! + DO I = 1, N + X(N,I) = B(INDX(N),I)/A(INDX(N),N) + DO J = N-1, 1, -1 + X(J,I) = B(INDX(J),I) + DO K = J+1, N + X(J,I) = X(J,I)-A(INDX(J),K)*X(K,I) + END DO + X(J,I) = X(J,I)/A(INDX(J),J) + END DO + END DO +END SUBROUTINE MIGS +! +SUBROUTINE ELGS (A,N,INDX) +! +! Subroutine to perform the partial-pivoting Gaussian elimination. +! A(N,N) is the original matrix in the input and transformed matrix +! plus the pivoting element ratios below the diagonal in the output. +! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001. +! + IMPLICIT NONE + INTEGER, INTENT (IN) :: N + INTEGER :: I,J,K,ITMP + INTEGER, INTENT (OUT), DIMENSION (N) :: INDX + REAL :: C1,PI,PI1,PJ + REAL, INTENT (INOUT), DIMENSION (N,N) :: A + REAL, DIMENSION (N) :: C +! +! Initialize the index +! + DO I = 1, N + INDX(I) = I + END DO +! +! Find the rescaling factors, one from each row +! + DO I = 1, N + C1= 0.0 + DO J = 1, N + C1 = AMAX1(C1,ABS(A(I,J))) + END DO + C(I) = C1 + END DO +! +! Search the pivoting (largest) element from each column +! + DO J = 1, N-1 + PI1 = 0.0 + DO I = J, N + PI = ABS(A(INDX(I),J))/C(INDX(I)) + IF (PI.GT.PI1) THEN + PI1 = PI + K = I + ENDIF + END DO +! +! Interchange the rows via INDX(N) to record pivoting order +! + ITMP = INDX(J) + INDX(J) = INDX(K) + INDX(K) = ITMP + DO I = J+1, N + PJ = A(INDX(I),J)/A(INDX(J),J) +! +! Record pivoting ratios below the diagonal +! + A(INDX(I),J) = PJ +! +! Modify other elements accordingly +! + DO K = J+1, N + A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K) + END DO + END DO + END DO +! +END SUBROUTINE ELGS + + + + + diff --git a/ED/src/dynamics/canopy_struct_dynamics.f90 b/ED/src/dynamics/canopy_struct_dynamics.f90 index 086112c4e..f355484b1 100644 --- a/ED/src/dynamics/canopy_struct_dynamics.f90 +++ b/ED/src/dynamics/canopy_struct_dynamics.f90 @@ -127,19 +127,23 @@ subroutine canopy_turbulence(cpoly,isi,ipa) , windext_half & ! intent(out) , zero_canopy_layer ! ! subroutine use consts_coms , only : vonk & ! intent(in) - , cp & ! intent(in) - , cpi & ! intent(in) , grav & ! intent(in) , epim1 & ! intent(in) , sqrt2o2 & ! intent(in) , srthree & ! intent(in) , onethird & ! intent(in) , twothirds & ! intent(in) - , kin_visci ! ! intent(in) + , kin_visci & ! intent(in) + , cpdry & ! intent(in) + , cph2o ! ! intent(in) use soil_coms , only : snow_rough & ! intent(in) , soil_rough ! ! intent(in) + use therm_lib , only : press2exner & ! function + , extheta2temp & ! function + , tq2enthalpy ! ! function use allometry , only : h2crownbh & ! function , dbh2bl ! ! function + use phenology_coms , only : elongf_min ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! type(polygontype) , target :: cpoly ! Current polygon @@ -166,7 +170,12 @@ subroutine canopy_turbulence(cpoly,isi,ipa) logical :: acomp ! Flag to check for convergence [ T|F] real :: rasveg ! Resistance of vegetated ground [ s/m] real :: atm_thetav ! Free atmosphere virtual potential temp. [ K] - real :: can_thetav ! Free atmosphere virtual potential temp. [ K] + real :: can_thetav ! Canopy air space virtual potential temp. [ K] + real :: atm_exn_zcan ! Atmospheric Exner function at can. depth [ J/kg/K] + real :: atm_tmp_zcan ! Atmospheric temperature at can. depth [ K] + real :: can_enthalpy ! Canopy air space specific enthalpy. [ J/kg] + real :: atm_enthalpy ! Free atmosphere specific enthalpy. [ J/kg] + real :: can_cp ! Canopy air space specific heat [ J/kg/K] real :: ldga_bk ! Cumulative leaf drag area [ ---] real :: lyrhalf ! Half the contrib. of this layer to zeta [ 1/m] real :: sigmakm ! Km coefficient at z=h [ m] @@ -180,8 +189,10 @@ subroutine canopy_turbulence(cpoly,isi,ipa) real :: estar ! Equivalent potential temperature [ K] real :: gbhmos_min ! Minimum boundary layer heat conductance. [ m/s] real :: wcapcan ! Canopy air space water capacity [ kg/m2] + real :: hcapcan ! Canopy air space enthalpy capacity [ J/m2] + real :: ccapcan ! Canopy air space CO2 capacity [ mol/m2] real :: wcapcani ! Inverse of the guy above [ m2/kg] - real :: hcapcani ! Inverse of canopy air space heat cap. [ m2.K/J] + real :: hcapcani ! Inverse of canopy air space enthalpy cap.[ m2/J] real :: ccapcani ! Inverse of canopy air space CO2 capacity [ m2/mol] real :: ustarouh ! The ratio of ustar over u(h) [ ---] real :: nn ! In-canopy wind attenuation scal. param. [ ---] @@ -217,6 +228,8 @@ subroutine canopy_turbulence(cpoly,isi,ipa) real :: can_reynolds ! Reynolds number of the Sfc. mixing layer [ ---] real :: ground_temp ! Ground temperature [ ---] real :: stab_clm4 ! Stability parameter (CLM4, eq. 5.104) [ ---] + logical :: dry_grasses ! Flag to check whether LAI+WAI is zero [ ---] + real :: tai_drygrass ! TAI for when a grass-only patch is dry [ m2/m2] !----- External functions. ----------------------------------------------------------! real(kind=4), external :: cbrt ! Cubic root that works for negative numbers !------------------------------------------------------------------------------------! @@ -235,6 +248,30 @@ subroutine canopy_turbulence(cpoly,isi,ipa) atm_thetav = cmet%atm_theta * (1. + epim1 * cmet%atm_shv ) can_thetav = csite%can_theta(ipa) * (1. + epim1 * csite%can_shv(ipa)) stable = atm_thetav >= can_thetav + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the free atmosphere enthalpy at the canopy air space height. ! + !------------------------------------------------------------------------------------! + atm_exn_zcan = press2exner (csite%can_prss(ipa)) + atm_tmp_zcan = extheta2temp(atm_exn_zcan,cmet%atm_theta) + atm_enthalpy = tq2enthalpy (atm_tmp_zcan,cmet%atm_shv,.true.) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the enthalpy of the canopy air space. ! + !------------------------------------------------------------------------------------! + can_enthalpy = tq2enthalpy(csite%can_temp(ipa),csite%can_shv(ipa),.true.) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the specific heat at constant pressure for this canopy air space. ! + !------------------------------------------------------------------------------------! + can_cp = (1.0 - csite%can_shv(ipa)) * cpdry + csite%can_shv(ipa) * cph2o + !------------------------------------------------------------------------------------! @@ -254,14 +291,18 @@ subroutine canopy_turbulence(cpoly,isi,ipa) !----- Calculate the surface roughness inside the canopy. ------------------------! csite%rough(ipa) = soil_rough * (1.0 - csite%snowfac(ipa)) & + snow_rough * csite%snowfac(ipa) - - !----- Finding the characteristic scales (a.k.a. stars). -------------------------! - call ed_stars(cmet%atm_theta,cmet%atm_theiv,cmet%atm_shv,cmet%atm_co2 & - ,csite%can_theta(ipa),csite%can_theiv(ipa),csite%can_shv(ipa) & + !---------------------------------------------------------------------------------! + + + !----- Find the characteristic scales (a.k.a. stars). ----------------------------! + call ed_stars(cmet%atm_theta,atm_enthalpy,cmet%atm_shv,cmet%atm_co2 & + ,csite%can_theta(ipa),can_enthalpy,csite%can_shv(ipa) & ,csite%can_co2(ipa),cmet%geoht,csite%veg_displace(ipa),cmet%vels & ,csite%rough(ipa),csite%ustar(ipa),csite%tstar(ipa),estar & ,csite%qstar(ipa),csite%cstar(ipa),csite%zeta(ipa),csite%ribulk(ipa) & ,csite%ggbare(ipa)) + !---------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------! ! This is a bare ground cohort, so there is no vegetated ground. Assign ! @@ -276,8 +317,8 @@ subroutine canopy_turbulence(cpoly,isi,ipa) !---------------------------------------------------------------------------------! ! Calculate the heat and mass storage capacity of the canopy. ! !---------------------------------------------------------------------------------! - call can_whcap(csite%can_rhos(ipa),csite%can_temp(ipa),csite%can_depth(ipa) & - ,wcapcan,wcapcani,hcapcani,ccapcani) + call can_whccap(csite%can_rhos(ipa),csite%can_depth(ipa) & + ,wcapcan,hcapcan,ccapcan,wcapcani,hcapcani,ccapcani) !---------------------------------------------------------------------------------! return end if @@ -347,8 +388,8 @@ subroutine canopy_turbulence(cpoly,isi,ipa) ! Get ustar for the ABL, assume it is a dynamic shear layer that generates a ! ! logarithmic profile of velocity. ! !---------------------------------------------------------------------------------! - call ed_stars(cmet%atm_theta,cmet%atm_theiv,cmet%atm_shv,cmet%atm_co2 & - ,csite%can_theta(ipa),csite%can_theiv(ipa),csite%can_shv(ipa) & + call ed_stars(cmet%atm_theta,atm_enthalpy,cmet%atm_shv,cmet%atm_co2 & + ,csite%can_theta(ipa),can_enthalpy,csite%can_shv(ipa) & ,csite%can_co2(ipa),cmet%geoht,csite%veg_displace(ipa),cmet%vels & ,csite%rough(ipa),csite%ustar(ipa),csite%tstar(ipa),estar & ,csite%qstar(ipa),csite%cstar(ipa),csite%zeta(ipa),csite%ribulk(ipa) & @@ -453,6 +494,7 @@ subroutine canopy_turbulence(cpoly,isi,ipa) ,csite%can_temp(ipa) & ,csite%can_shv(ipa) & ,csite%can_rhos(ipa) & + ,can_cp & ,gbhmos_min & ,cpatch%leaf_gbh(ico) & ,cpatch%leaf_gbw(ico)) @@ -472,6 +514,7 @@ subroutine canopy_turbulence(cpoly,isi,ipa) ,csite%can_temp(ipa) & ,csite%can_shv(ipa) & ,csite%can_rhos(ipa) & + ,can_cp & ,gbhmos_min & ,cpatch%wood_gbh(ico) & ,cpatch%wood_gbw(ico)) @@ -489,8 +532,8 @@ subroutine canopy_turbulence(cpoly,isi,ipa) !---------------------------------------------------------------------------------! ! Calculate the heat and mass storage capacity of the canopy. ! !---------------------------------------------------------------------------------! - call can_whcap(csite%can_rhos(ipa),csite%can_temp(ipa),csite%can_depth(ipa) & - ,wcapcan,wcapcani,hcapcani,ccapcani) + call can_whccap(csite%can_rhos(ipa),csite%can_depth(ipa) & + ,wcapcan,hcapcan,ccapcan,wcapcani,hcapcani,ccapcani) !---------------------------------------------------------------------------------! @@ -553,8 +596,8 @@ subroutine canopy_turbulence(cpoly,isi,ipa) ! Get ustar for the ABL, assume it is a dynamic shear layer that generates a ! ! logarithmic profile of velocity. ! !---------------------------------------------------------------------------------! - call ed_stars(cmet%atm_theta,cmet%atm_theiv,cmet%atm_shv,cmet%atm_co2 & - ,csite%can_theta(ipa),csite%can_theiv(ipa),csite%can_shv(ipa) & + call ed_stars(cmet%atm_theta,atm_enthalpy,cmet%atm_shv,cmet%atm_co2 & + ,csite%can_theta(ipa),can_enthalpy,csite%can_shv(ipa) & ,csite%can_co2(ipa),cmet%geoht,csite%veg_displace(ipa),cmet%vels & ,csite%rough(ipa),csite%ustar(ipa),csite%tstar(ipa),estar & ,csite%qstar(ipa),csite%cstar(ipa),csite%zeta(ipa),csite%ribulk(ipa) & @@ -620,6 +663,7 @@ subroutine canopy_turbulence(cpoly,isi,ipa) ,csite%can_temp(ipa) & ,csite%can_shv(ipa) & ,csite%can_rhos(ipa) & + ,can_cp & ,gbhmos_min & ,cpatch%leaf_gbh(ico) & ,cpatch%leaf_gbw(ico)) @@ -639,6 +683,7 @@ subroutine canopy_turbulence(cpoly,isi,ipa) ,csite%can_temp(ipa) & ,csite%can_shv(ipa) & ,csite%can_rhos(ipa) & + ,can_cp & ,gbhmos_min & ,cpatch%wood_gbh(ico) & ,cpatch%wood_gbw(ico)) @@ -655,8 +700,8 @@ subroutine canopy_turbulence(cpoly,isi,ipa) !---------------------------------------------------------------------------------! ! Calculate the heat and mass storage capacity of the canopy. ! !---------------------------------------------------------------------------------! - call can_whcap(csite%can_rhos(ipa),csite%can_temp(ipa),csite%can_depth(ipa) & - ,wcapcan,wcapcani,hcapcani,ccapcani) + call can_whccap(csite%can_rhos(ipa),csite%can_depth(ipa) & + ,wcapcan,hcapcan,ccapcan,wcapcani,hcapcani,ccapcani) !---------------------------------------------------------------------------------! @@ -774,6 +819,16 @@ subroutine canopy_turbulence(cpoly,isi,ipa) end do case default + + !------------------------------------------------------------------------------! + ! Branches are turned on. In arid places, there is a chance that all ! + ! cohorts will be grasses with phenology status is set to 2. This creates a ! + ! singularity, so we must check whether this is the case. ! + !------------------------------------------------------------------------------! + dry_grasses = sum(cpatch%lai(:)+cpatch%wai(:)) == 0.0 + !------------------------------------------------------------------------------! + + !----- Use the default wood area index. ---------------------------------------! do ico=1,cpatch%ncohorts ipft = cpatch%pft(ico) @@ -783,7 +838,22 @@ subroutine canopy_turbulence(cpoly,isi,ipa) !---------------------------------------------------------------------------! htopcrown = cpatch%hite(ico) hbotcrown = h2crownbh(cpatch%hite(ico),ipft) - ladcohort = (cpatch%lai(ico) + cpatch%wai(ico)) / (htopcrown - hbotcrown) + if (dry_grasses) then + !------------------------------------------------------------------------! + ! Dry grasses only. Create a pseudo TAI so it won't be a ! + ! singularity. ! + !------------------------------------------------------------------------! + tai_drygrass = elongf_min * dbh2bl(cpatch%dbh(ico),ipft) + ladcohort = tai_drygrass / (htopcrown - hbotcrown) + !------------------------------------------------------------------------! + else + !------------------------------------------------------------------------! + ! At least one plant has branches or leaves, use the real stuff ! + ! instead. ! + !------------------------------------------------------------------------! + ladcohort = (cpatch%lai(ico) + cpatch%wai(ico)) / (htopcrown - hbotcrown) + !------------------------------------------------------------------------! + end if kapartial = min(ncanlyr,floor ((hbotcrown * zztop0i)**ehgti) + 1) kafull = min(ncanlyr,ceiling((hbotcrown * zztop0i)**ehgti) + 1) kzpartial = min(ncanlyr,ceiling((htopcrown * zztop0i)**ehgti)) @@ -913,9 +983,12 @@ subroutine canopy_turbulence(cpoly,isi,ipa) - !----- Find the characteristic scales (a.k.a. stars). ----------------------------! - call ed_stars(cmet%atm_theta,cmet%atm_theiv,cmet%atm_shv,cmet%atm_co2 & - ,csite%can_theta(ipa),csite%can_theiv(ipa),csite%can_shv(ipa) & + !---------------------------------------------------------------------------------! + ! Get ustar for the ABL, assume it is a dynamic shear layer that generates a ! + ! logarithmic profile of velocity. ! + !---------------------------------------------------------------------------------! + call ed_stars(cmet%atm_theta,atm_enthalpy,cmet%atm_shv,cmet%atm_co2 & + ,csite%can_theta(ipa),can_enthalpy,csite%can_shv(ipa) & ,csite%can_co2(ipa),cmet%geoht,csite%veg_displace(ipa),cmet%vels & ,csite%rough(ipa),csite%ustar(ipa),csite%tstar(ipa),estar & ,csite%qstar(ipa),csite%cstar(ipa),csite%zeta(ipa),csite%ribulk(ipa) & @@ -967,6 +1040,7 @@ subroutine canopy_turbulence(cpoly,isi,ipa) ,csite%can_temp(ipa) & ,csite%can_shv(ipa) & ,csite%can_rhos(ipa) & + ,can_cp & ,gbhmos_min & ,cpatch%leaf_gbh(ico) & ,cpatch%leaf_gbw(ico)) @@ -986,6 +1060,7 @@ subroutine canopy_turbulence(cpoly,isi,ipa) ,csite%can_temp(ipa) & ,csite%can_shv(ipa) & ,csite%can_rhos(ipa) & + ,can_cp & ,gbhmos_min & ,cpatch%wood_gbh(ico) & ,cpatch%wood_gbw(ico)) @@ -1168,8 +1243,8 @@ subroutine canopy_turbulence(cpoly,isi,ipa) !---------------------------------------------------------------------------------! ! Calculate the heat and mass storage capacity of the canopy. ! !---------------------------------------------------------------------------------! - call can_whcap(csite%can_rhos(ipa),csite%can_temp(ipa),csite%can_depth(ipa) & - ,wcapcan,wcapcani,hcapcani,ccapcani) + call can_whccap(csite%can_rhos(ipa),csite%can_depth(ipa) & + ,wcapcan,hcapcan,ccapcan,wcapcani,hcapcani,ccapcani) !---------------------------------------------------------------------------------! end select @@ -1261,6 +1336,8 @@ subroutine canopy_turbulence8(csite,initp,ipa) , tiny_offset & ! intent(in) , ibranch_thermo & ! intent(in) , wcapcan & ! intent(out) + , hcapcan & ! intent(out) + , ccapcan & ! intent(out) , wcapcani & ! intent(out) , hcapcani & ! intent(out) , ccapcani ! ! intent(out) @@ -1305,7 +1382,6 @@ subroutine canopy_turbulence8(csite,initp,ipa) , windext_half8 & ! intent(out) , zero_canopy_layer ! ! subroutine use consts_coms , only : vonk8 & ! intent(in) - , cpi8 & ! intent(in) , grav8 & ! intent(in) , epim18 & ! intent(in) , sqrt2o28 & ! intent(in) @@ -1317,6 +1393,7 @@ subroutine canopy_turbulence8(csite,initp,ipa) , soil_rough8 ! ! intent(in) use allometry , only : h2crownbh & ! function , dbh2bl ! ! function + use phenology_coms , only : elongf_min ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! type(sitetype) , target :: csite ! Current site @@ -1387,6 +1464,8 @@ subroutine canopy_turbulence8(csite,initp,ipa) real(kind=8) :: can_reynolds ! Reynolds number of the sfc. mixing layer [ ---] real(kind=8) :: ground_temp ! Ground temperature [ ---] real(kind=8) :: stab_clm4 ! Stability parameter (CLM4, eq. 5.104) [ ---] + logical :: dry_grasses ! Flag to check whether LAI+WAI is zero [ ---] + real(kind=8) :: tai_drygrass ! TAI for when a grass-only patch is dry [ m2/m2] !------ External procedures ---------------------------------------------------------! real(kind=8), external :: cbrt8 ! Cubic root that works for negative numbers real(kind=4), external :: sngloff ! Safe double -> simple precision. @@ -1416,9 +1495,9 @@ subroutine canopy_turbulence8(csite,initp,ipa) !----- Calculate the surface roughness inside the canopy. ------------------------! initp%rough = soil_rough8 *(1.d0 - initp%snowfac) + snow_rough8 * initp%snowfac - !----- Finding the characteristic scales (a.k.a. stars). -------------------------! - call ed_stars8(rk4site%atm_theta,rk4site%atm_theiv,rk4site%atm_shv & - ,rk4site%atm_co2,initp%can_theta ,initp%can_theiv ,initp%can_shv & + !----- Find the characteristic scales (a.k.a. stars). ----------------------------! + call ed_stars8(rk4site%atm_theta,rk4site%atm_enthalpy,rk4site%atm_shv & + ,rk4site%atm_co2,initp%can_theta ,initp%can_enthalpy,initp%can_shv & ,initp%can_co2,rk4site%geoht,initp%veg_displace,rk4site%vels & ,initp%rough,initp%ustar,initp%tstar,initp%estar,initp%qstar & ,initp%cstar,initp%zeta,initp%ribulk,initp%ggbare) @@ -1439,8 +1518,8 @@ subroutine canopy_turbulence8(csite,initp,ipa) !---------------------------------------------------------------------------------! ! Calculate the heat and mass storage capacity of the canopy. ! !---------------------------------------------------------------------------------! - call can_whcap8(initp%can_rhos,initp%can_temp,initp%can_depth & - ,wcapcan,wcapcani,hcapcani,ccapcani) + call can_whccap8(initp%can_rhos,initp%can_depth & + ,wcapcan,hcapcan,ccapcan,wcapcani,hcapcani,ccapcani) !---------------------------------------------------------------------------------! return @@ -1496,8 +1575,8 @@ subroutine canopy_turbulence8(csite,initp,ipa) ! Get ustar for the ABL, assume it is a dynamic shear layer that generates a ! ! logarithmic profile of velocity. ! !---------------------------------------------------------------------------------! - call ed_stars8(rk4site%atm_theta,rk4site%atm_theiv,rk4site%atm_shv & - ,rk4site%atm_co2,initp%can_theta ,initp%can_theiv,initp%can_shv & + call ed_stars8(rk4site%atm_theta,rk4site%atm_enthalpy,rk4site%atm_shv & + ,rk4site%atm_co2,initp%can_theta ,initp%can_enthalpy,initp%can_shv & ,initp%can_co2,rk4site%geoht,initp%veg_displace,rk4site%vels & ,initp%rough,initp%ustar,initp%tstar,initp%estar,initp%qstar & ,initp%cstar,initp%zeta,initp%ribulk,initp%ggbare) @@ -1594,7 +1673,8 @@ subroutine canopy_turbulence8(csite,initp,ipa) !---------------------------------------------------------------------------! call leaf_aerodynamic_conductances8(ipft,initp%veg_wind(ico) & ,initp%leaf_temp(ico),initp%can_temp & - ,initp%can_shv,initp%can_rhos,gbhmos_min & + ,initp%can_shv,initp%can_rhos & + ,initp%can_cp,gbhmos_min & ,initp%leaf_gbh(ico),initp%leaf_gbw(ico) & ,initp%leaf_reynolds(ico) & ,initp%leaf_grashof(ico) & @@ -1622,7 +1702,8 @@ subroutine canopy_turbulence8(csite,initp,ipa) call wood_aerodynamic_conductances8(ipft,cpatch%dbh(ico),cpatch%hite(ico) & ,initp%veg_wind(ico) & ,initp%wood_temp(ico),initp%can_temp & - ,initp%can_shv,initp%can_rhos,gbhmos_min & + ,initp%can_shv,initp%can_rhos & + ,initp%can_cp,gbhmos_min & ,initp%wood_gbh(ico),initp%wood_gbw(ico) & ,initp%wood_reynolds(ico) & ,initp%wood_grashof(ico) & @@ -1648,8 +1729,8 @@ subroutine canopy_turbulence8(csite,initp,ipa) !---------------------------------------------------------------------------------! ! Calculate the heat and mass storage capacity of the canopy. ! !---------------------------------------------------------------------------------! - call can_whcap8(initp%can_rhos,initp%can_temp,initp%can_depth & - ,wcapcan,wcapcani,hcapcani,ccapcani) + call can_whccap8(initp%can_rhos,initp%can_depth & + ,wcapcan,hcapcan,ccapcan,wcapcani,hcapcani,ccapcani) !---------------------------------------------------------------------------------! @@ -1698,11 +1779,12 @@ subroutine canopy_turbulence8(csite,initp,ipa) ! Get ustar for the ABL, assume it is a dynamic shear layer that generates a ! ! logarithmic profile of velocity. ! !---------------------------------------------------------------------------------! - call ed_stars8(rk4site%atm_theta,rk4site%atm_theiv,rk4site%atm_shv & - ,rk4site%atm_co2,initp%can_theta,initp%can_theiv,initp%can_shv & + call ed_stars8(rk4site%atm_theta,rk4site%atm_enthalpy,rk4site%atm_shv & + ,rk4site%atm_co2,initp%can_theta ,initp%can_enthalpy,initp%can_shv & ,initp%can_co2,rk4site%geoht,initp%veg_displace,rk4site%vels & ,initp%rough,initp%ustar,initp%tstar,initp%estar,initp%qstar & ,initp%cstar,initp%zeta,initp%ribulk,initp%ggbare) + !---------------------------------------------------------------------------------! !---------------------------------------------------------------------------------! @@ -1754,7 +1836,8 @@ subroutine canopy_turbulence8(csite,initp,ipa) !---------------------------------------------------------------------------! call leaf_aerodynamic_conductances8(ipft,initp%veg_wind(ico) & ,initp%leaf_temp(ico),initp%can_temp & - ,initp%can_shv,initp%can_rhos,gbhmos_min & + ,initp%can_shv,initp%can_rhos & + ,initp%can_cp,gbhmos_min & ,initp%leaf_gbh(ico),initp%leaf_gbw(ico) & ,initp%leaf_reynolds(ico) & ,initp%leaf_grashof(ico) & @@ -1782,7 +1865,8 @@ subroutine canopy_turbulence8(csite,initp,ipa) call wood_aerodynamic_conductances8(ipft,cpatch%dbh(ico),cpatch%hite(ico) & ,initp%veg_wind(ico) & ,initp%wood_temp(ico),initp%can_temp & - ,initp%can_shv,initp%can_rhos,gbhmos_min & + ,initp%can_shv,initp%can_rhos & + ,initp%can_cp,gbhmos_min & ,initp%wood_gbh(ico),initp%wood_gbw(ico) & ,initp%wood_reynolds(ico) & ,initp%wood_grashof(ico) & @@ -1810,8 +1894,8 @@ subroutine canopy_turbulence8(csite,initp,ipa) !---------------------------------------------------------------------------------! ! Calculate the heat and mass storage capacity of the canopy. ! !---------------------------------------------------------------------------------! - call can_whcap8(initp%can_rhos,initp%can_temp,initp%can_depth & - ,wcapcan,wcapcani,hcapcani,ccapcani) + call can_whccap8(initp%can_rhos,initp%can_depth & + ,wcapcan,hcapcan,ccapcan,wcapcani,hcapcani,ccapcani) !---------------------------------------------------------------------------------! @@ -1916,6 +2000,16 @@ subroutine canopy_turbulence8(csite,initp,ipa) end do case default + + !------------------------------------------------------------------------------! + ! Branches are turned on. In arid places, there is a chance that all ! + ! cohorts will be grasses with phenology status is set to 2. This creates a ! + ! singularity, so we must check whether this is the case. ! + !------------------------------------------------------------------------------! + dry_grasses = sum(cpatch%lai(:)+cpatch%wai(:)) == 0.0 + !------------------------------------------------------------------------------! + + !----- Use the default wood area index. ---------------------------------------! do ico=1,cpatch%ncohorts ipft = cpatch%pft(ico) @@ -1925,7 +2019,22 @@ subroutine canopy_turbulence8(csite,initp,ipa) !---------------------------------------------------------------------------! htopcrown = dble(cpatch%hite(ico)) hbotcrown = dble(h2crownbh(cpatch%hite(ico),ipft)) - ladcohort = (initp%lai(ico) + initp%wai(ico)) / (htopcrown - hbotcrown) + if (dry_grasses) then + !------------------------------------------------------------------------! + ! Dry grasses only. Create a pseudo TAI so it won't be a ! + ! singularity. ! + !------------------------------------------------------------------------! + tai_drygrass = dble(elongf_min * dbh2bl(cpatch%dbh(ico),ipft)) + ladcohort = tai_drygrass / (htopcrown - hbotcrown) + !------------------------------------------------------------------------! + else + !------------------------------------------------------------------------! + ! At least one plant has branches or leaves, use the real stuff ! + ! instead. ! + !------------------------------------------------------------------------! + ladcohort = (initp%lai(ico) + initp%wai(ico)) / (htopcrown - hbotcrown) + !------------------------------------------------------------------------! + end if kapartial = min(ncanlyr,floor ((hbotcrown * zztop0i8)**ehgti8) + 1) kafull = min(ncanlyr,ceiling((hbotcrown * zztop0i8)**ehgti8) + 1) kzpartial = min(ncanlyr,ceiling((htopcrown * zztop0i8)**ehgti8)) @@ -2056,8 +2165,8 @@ subroutine canopy_turbulence8(csite,initp,ipa) !----- Calculate ustar, tstar, qstar, and cstar. ---------------------------------! - call ed_stars8(rk4site%atm_theta,rk4site%atm_theiv,rk4site%atm_shv & - ,rk4site%atm_co2,initp%can_theta,initp%can_theiv,initp%can_shv & + call ed_stars8(rk4site%atm_theta,rk4site%atm_enthalpy,rk4site%atm_shv & + ,rk4site%atm_co2,initp%can_theta ,initp%can_enthalpy,initp%can_shv & ,initp%can_co2,rk4site%geoht,initp%veg_displace,rk4site%vels & ,initp%rough,initp%ustar,initp%tstar,initp%estar,initp%qstar & ,initp%cstar,initp%zeta,initp%ribulk,initp%ggbare) @@ -2102,7 +2211,8 @@ subroutine canopy_turbulence8(csite,initp,ipa) !---------------------------------------------------------------------------! call leaf_aerodynamic_conductances8(ipft,initp%veg_wind(ico) & ,initp%leaf_temp(ico),initp%can_temp & - ,initp%can_shv,initp%can_rhos,gbhmos_min & + ,initp%can_shv,initp%can_rhos & + ,initp%can_cp,gbhmos_min & ,initp%leaf_gbh(ico),initp%leaf_gbw(ico) & ,initp%leaf_reynolds(ico) & ,initp%leaf_grashof(ico) & @@ -2130,7 +2240,8 @@ subroutine canopy_turbulence8(csite,initp,ipa) call wood_aerodynamic_conductances8(ipft,cpatch%dbh(ico),cpatch%hite(ico) & ,initp%veg_wind(ico) & ,initp%wood_temp(ico),initp%can_temp & - ,initp%can_shv,initp%can_rhos,gbhmos_min & + ,initp%can_shv,initp%can_rhos & + ,initp%can_cp,gbhmos_min & ,initp%wood_gbh(ico),initp%wood_gbw(ico) & ,initp%wood_reynolds(ico) & ,initp%wood_grashof(ico) & @@ -2323,8 +2434,8 @@ subroutine canopy_turbulence8(csite,initp,ipa) !---------------------------------------------------------------------------------! ! Calculate the heat and mass storage capacity of the canopy. ! !---------------------------------------------------------------------------------! - call can_whcap8(initp%can_rhos,initp%can_temp,initp%can_depth & - ,wcapcan,wcapcani,hcapcani,ccapcani) + call can_whccap8(initp%can_rhos,initp%can_depth & + ,wcapcan,hcapcan,ccapcan,wcapcani,hcapcani,ccapcani) !---------------------------------------------------------------------------------! end select @@ -2375,7 +2486,7 @@ end subroutine canopy_turbulence8 ! NCAR Technical Note NCAR/TN-461+STR, Boulder, CO, May 2004. ! ! ! !---------------------------------------------------------------------------------------! - subroutine ed_stars(theta_atm,theiv_atm,shv_atm,co2_atm,theta_can,theiv_can & + subroutine ed_stars(theta_atm,enthalpy_atm,shv_atm,co2_atm,theta_can,enthalpy_can & ,shv_can,co2_can,zref,dheight,uref,rough,ustar,tstar,estar,qstar & ,cstar,zeta,rib,ggbare) use consts_coms , only : grav & ! intent(in) @@ -2397,57 +2508,58 @@ subroutine ed_stars(theta_atm,theiv_atm,shv_atm,co2_atm,theta_can,theiv_can , zoobukhov ! ! function use rk4_coms , only : rk4_tolerance ! ! intent(in) implicit none - !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: theta_atm ! Above canopy air pot. temperature [ K] - real, intent(in) :: theiv_atm ! Above canopy air eq. pot. temperature [ K] - real, intent(in) :: shv_atm ! Above canopy vapour spec. hum. [kg/kg_air] - real, intent(in) :: co2_atm ! CO2 mixing ratio [ µmol/mol] - real, intent(in) :: theta_can ! Canopy air potential temperature [ K] - real, intent(in) :: theiv_can ! Canopy air eq. pot. temperature [ K] - real, intent(in) :: shv_can ! Canopy air vapour spec. humidity [kg/kg_air] - real, intent(in) :: co2_can ! Canopy air CO2 mixing ratio [ µmol/mol] - real, intent(in) :: zref ! Height at reference point [ m] - real, intent(in) :: dheight ! Zero-plane displacement height [ m] - real, intent(in) :: uref ! Wind speed at reference height [ m/s] - real, intent(in) :: rough ! Roughness [ m] - real, intent(out) :: ustar ! U*, friction velocity [ m/s] - real, intent(out) :: qstar ! Specific humidity turbulence scale [kg/kg_air] - real, intent(out) :: tstar ! Temperature turbulence scale [ K] - real, intent(out) :: estar ! Equivalent pot. temp. turb. scale [ K] - real, intent(out) :: cstar ! CO2 mixing ratio turbulence scale [ µmol/mol] - real, intent(out) :: zeta ! z/(Obukhov length). [ -----] - real, intent(out) :: rib ! Bulk richardson number. [ -----] - real, intent(out) :: ggbare ! Ground conductance [ m/s] - !----- Local variables --------------------------------------------------------------! - logical :: stable ! Stable state - real :: zoz0m ! zref/rough(momentum) - real :: lnzoz0m ! ln[zref/rough(momentum)] - real :: zoz0h ! zref/rough(heat) - real :: lnzoz0h ! ln[zref/rough(heat)] - real :: c3 ! coefficient to find the other stars - real :: uuse ! Wind for too stable cases (Rib > Ribmax) + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: theta_atm ! Above canopy air pot. temp. [ K] + real(kind=4), intent(in) :: enthalpy_atm ! Above can. air spec. enthalpy [ J/kg_air] + real(kind=4), intent(in) :: shv_atm ! Above can. vapour spec. hum. [kg/kg_air] + real(kind=4), intent(in) :: co2_atm ! CO2 mixing ratio [ µmol/mol] + real(kind=4), intent(in) :: theta_can ! Canopy air pot. temperature [ K] + real(kind=4), intent(in) :: enthalpy_can ! Canopy air specific enthalpy [ J/kg_air] + real(kind=4), intent(in) :: shv_can ! Canopy air vapour spec. hum. [kg/kg_air] + real(kind=4), intent(in) :: co2_can ! Canopy air CO2 mixing ratio [ µmol/mol] + real(kind=4), intent(in) :: zref ! Height at reference point [ m] + real(kind=4), intent(in) :: dheight ! Zero-plane displacement hgt. [ m] + real(kind=4), intent(in) :: uref ! Wind speed at reference hgt. [ m/s] + real(kind=4), intent(in) :: rough ! Roughness [ m] + real(kind=4), intent(out) :: ustar ! U*, friction velocity [ m/s] + real(kind=4), intent(out) :: qstar ! Specific humidity turb. scale [kg/kg_air] + real(kind=4), intent(out) :: tstar ! Temperature turbulence scale [ K] + real(kind=4), intent(out) :: estar ! Spec. enthalpy turb. scale [ J/kg_air] + real(kind=4), intent(out) :: cstar ! CO2 mixing ratio turb. scale [ µmol/mol] + real(kind=4), intent(out) :: zeta ! z/(Obukhov length). [ -----] + real(kind=4), intent(out) :: rib ! Bulk richardson number. [ -----] + real(kind=4), intent(out) :: ggbare ! Ground conductance [ m/s] + !----- Local variables. -------------------------------------------------------------! + logical :: stable ! Stable state [ T|F] + real(kind=4) :: zoz0m ! zref/rough(momentum) [ -----] + real(kind=4) :: lnzoz0m ! ln[zref/rough(momentum)] [ -----] + real(kind=4) :: zoz0h ! zref/rough(heat) [ -----] + real(kind=4) :: lnzoz0h ! ln[zref/rough(heat)] [ -----] + real(kind=4) :: c3 ! aux. coefficient [ -----] + real(kind=4) :: uuse ! Wind for when (Rib > Ribmax) [ m/s] !----- Local variables, used by L79. ------------------------------------------------! - real :: a2 ! Drag coefficient in neutral conditions - real :: c1 ! a2 * vels - real :: fm ! Stability parameter for momentum - real :: fh ! Stability parameter for heat - real :: c2 ! Part of the c coeff. common to momentum & heat. - real :: cm ! c coefficient times |Rib|^1/2 for momentum. - real :: ch ! c coefficient times |Rib|^1/2 for heat. - real :: ee ! (z/z0)^1/3 -1. for eqn. 20 w/o assuming z/z0 >> 1. - !----- Local variables, used by others. ---------------------------------------------! - real :: zeta0m ! roughness(momentum)/(Obukhov length). - real :: zeta0h ! roughness(heat)/(Obukhov length). - real :: utotal ! Total wind (actual + convective) - real :: uconv ! Convective velocity - real :: uconv_prev ! Previous convective velocity - real :: change ! Difference in convective velocity + real(kind=4) :: a2 ! Drag coefficient in neutral conditions + real(kind=4) :: c1 ! a2 * vels + real(kind=4) :: fm ! Stability parameter for momentum + real(kind=4) :: fh ! Stability parameter for heat + real(kind=4) :: c2 ! Part of the c coefficient common + ! to momentum & heat. + real(kind=4) :: cm ! c times |Rib|^1/2 for momentum. + real(kind=4) :: ch ! c times |Rib|^1/2 for heat. + real(kind=4) :: ee ! (z/z0)^1/3 -1. for eqn. 20 + !----- Local variables, used by other schemes. --------------------------------------! + real(kind=4) :: zeta0m ! roughness(momentum)/(Obukhov length). + real(kind=4) :: zeta0h ! roughness(heat)/(Obukhov length). + real(kind=4) :: utotal ! Total wind (actual + convective) + real(kind=4) :: uconv ! Convective velocity + real(kind=4) :: uconv_prev ! Previous convective velocity + real(kind=4) :: change ! Difference in convective velocity integer :: icnt ! Iteration counter !----- Aux. environment conditions. -------------------------------------------------! - real :: thetav_atm ! Atmos. virtual potential temperature [ K] - real :: thetav_can ! Canopy air virtual pot. temperature [ K] + real(kind=4) :: thetav_atm ! Atmos. virtual pot. temp. [ K] + real(kind=4) :: thetav_can ! Canopy air virtual pot. temp. [ K] !----- External functions. ----------------------------------------------------------! - real, external :: cbrt ! Cubic root + real(kind=4), external :: cbrt ! Cubic root !------------------------------------------------------------------------------------! @@ -2643,10 +2755,10 @@ subroutine ed_stars(theta_atm,theiv_atm,shv_atm,co2_atm,theta_can,theiv_can end select !----- Compute the other scales. ----------------------------------------------------! - qstar = c3 * (shv_atm - shv_can ) - tstar = c3 * (theta_atm - theta_can ) - estar = c3 * log(theiv_atm / theiv_can ) - cstar = c3 * (co2_atm - co2_can ) + qstar = c3 * (shv_atm - shv_can ) + tstar = c3 * (theta_atm - theta_can ) + estar = c3 * (enthalpy_atm - enthalpy_can ) + cstar = c3 * (co2_atm - co2_can ) !------------------------------------------------------------------------------------! @@ -2704,8 +2816,8 @@ end subroutine ed_stars ! NCAR Technical Note NCAR/TN-461+STR, Boulder, CO, May 2004. ! ! ! !---------------------------------------------------------------------------------------! - subroutine ed_stars8(theta_atm,theiv_atm,shv_atm,co2_atm & - ,theta_can,theiv_can,shv_can,co2_can & + subroutine ed_stars8(theta_atm,enthalpy_atm,shv_atm,co2_atm & + ,theta_can,enthalpy_can,shv_can,co2_can & ,zref,dheight,uref,rough,ustar,tstar,estar,qstar,cstar,zeta,rib & ,ggbare) use consts_coms , only : grav8 & ! intent(in) @@ -2729,41 +2841,42 @@ subroutine ed_stars8(theta_atm,theiv_atm,shv_atm,co2_atm implicit none !----- Arguments --------------------------------------------------------------------! real(kind=8), intent(in) :: theta_atm ! Above canopy air pot. temp. [ K] - real(kind=8), intent(in) :: theiv_atm ! Above canopy air eq. pot. T [ K] - real(kind=8), intent(in) :: shv_atm ! Above canopy vap. spec. hum. [kg/kg_air] - real(kind=8), intent(in) :: co2_atm ! Above canopy CO2 mix. ratio [ µmol/mol] - real(kind=8), intent(in) :: theta_can ! Canopy air potential temp. [ K] - real(kind=8), intent(in) :: theiv_can ! Canopy air eq. pot. temp. [ K] + real(kind=8), intent(in) :: enthalpy_atm ! Above can. air spec. enthalpy [ J/kg_air] + real(kind=8), intent(in) :: shv_atm ! Above can. vapour spec. hum. [kg/kg_air] + real(kind=8), intent(in) :: co2_atm ! CO2 mixing ratio [ µmol/mol] + real(kind=8), intent(in) :: theta_can ! Canopy air pot. temperature [ K] + real(kind=8), intent(in) :: enthalpy_can ! Canopy air specific enthalpy [ J/kg_air] real(kind=8), intent(in) :: shv_can ! Canopy air vapour spec. hum. [kg/kg_air] - real(kind=8), intent(in) :: co2_can ! Canopy air CO2 spec. volume [ µmol/mol] + real(kind=8), intent(in) :: co2_can ! Canopy air CO2 mixing ratio [ µmol/mol] real(kind=8), intent(in) :: zref ! Height at reference point [ m] - real(kind=8), intent(in) :: dheight ! 0-plane displacement height [ m] - real(kind=8), intent(in) :: uref ! Wind speed at ref. height [ m/s] + real(kind=8), intent(in) :: dheight ! Zero-plane displacement hgt. [ m] + real(kind=8), intent(in) :: uref ! Wind speed at reference hgt. [ m/s] real(kind=8), intent(in) :: rough ! Roughness [ m] real(kind=8), intent(out) :: ustar ! U*, friction velocity [ m/s] - real(kind=8), intent(out) :: qstar ! Specific hum. turb. scale [kg/kg_air] - real(kind=8), intent(out) :: tstar ! Temperature turb. scale [ K] - real(kind=8), intent(out) :: estar ! Theta_E turbulence scale [ K] + real(kind=8), intent(out) :: qstar ! Specific humidity turb. scale [kg/kg_air] + real(kind=8), intent(out) :: tstar ! Temperature turbulence scale [ K] + real(kind=8), intent(out) :: estar ! Spec. enthalpy turb. scale [ J/kg_air] real(kind=8), intent(out) :: cstar ! CO2 mixing ratio turb. scale [ µmol/mol] - real(kind=8), intent(out) :: zeta ! z/(Obukhov length) [ ---] - real(kind=8), intent(out) :: rib ! Bulk richardson number. [ ---] - real(kind=8), intent(out) :: ggbare ! Ground conductance. [ m/s] + real(kind=8), intent(out) :: zeta ! z/(Obukhov length). [ -----] + real(kind=8), intent(out) :: rib ! Bulk richardson number. [ -----] + real(kind=8), intent(out) :: ggbare ! Ground conductance [ m/s] !----- Local variables --------------------------------------------------------------! - logical :: stable ! Stable state - real(kind=8) :: zoz0m ! zref/rough(momentum) - real(kind=8) :: lnzoz0m ! ln[zref/rough(momentum)] - real(kind=8) :: zoz0h ! zref/rough(heat) - real(kind=8) :: lnzoz0h ! ln[zref/rough(heat)] - real(kind=8) :: c3 ! coefficient to find the other stars - real(kind=8) :: uuse ! Wind for too stable cases (Rib > Ribmax) + logical :: stable ! Stable state [ T|F] + real(kind=8) :: zoz0m ! zref/rough(momentum) [ -----] + real(kind=8) :: lnzoz0m ! ln[zref/rough(momentum)] [ -----] + real(kind=8) :: zoz0h ! zref/rough(heat) [ -----] + real(kind=8) :: lnzoz0h ! ln[zref/rough(heat)] [ -----] + real(kind=8) :: c3 ! aux. coefficient [ -----] + real(kind=8) :: uuse ! Wind for when (Rib > Ribmax) [ m/s] !----- Local variables, used by L79. ------------------------------------------------! real(kind=8) :: a2 ! Drag coefficient in neutral conditions real(kind=8) :: c1 ! a2 * vels real(kind=8) :: fm ! Stability parameter for momentum real(kind=8) :: fh ! Stability parameter for heat - real(kind=8) :: c2 ! Part of the c common to momentum & heat. - real(kind=8) :: cm ! c coeff. times |Rib|^1/2 for momentum. - real(kind=8) :: ch ! c coefficient times |Rib|^1/2 for heat. + real(kind=8) :: c2 ! Part of the c coefficient common + ! to momentum & heat. + real(kind=8) :: cm ! c times |Rib|^1/2 for momentum. + real(kind=8) :: ch ! c times |Rib|^1/2 for heat. real(kind=8) :: ee ! (z/z0)^1/3 -1. for eqn. 20 !----- Local variables, used by others. ---------------------------------------------! real(kind=8) :: zeta0m ! roughness(momentum)/(Obukhov length). @@ -2973,10 +3086,10 @@ subroutine ed_stars8(theta_atm,theiv_atm,shv_atm,co2_atm !----- Compute the other scales. ----------------------------------------------------! - qstar = c3 * (shv_atm - shv_can ) - tstar = c3 * (theta_atm - theta_can ) - estar = c3 * log(theiv_atm / theiv_can ) - cstar = c3 * (co2_atm - co2_can ) + qstar = c3 * (shv_atm - shv_can ) + tstar = c3 * (theta_atm - theta_can ) + estar = c3 * (enthalpy_atm - enthalpy_can ) + cstar = c3 * (co2_atm - co2_can ) !------------------------------------------------------------------------------------! @@ -3309,27 +3422,47 @@ end function vertical_vel_flux8 ! Calculate some canopy air space properties, such as the total mass and depth, and ! ! also the total capacities (carbon, water, and heat). ! !---------------------------------------------------------------------------------------! - subroutine can_whcap(can_rhos,can_temp,can_depth,wcapcan,wcapcani,hcapcani,ccapcani) - use consts_coms, only : cpi & ! intent(in) - , mmdry ! ! intent(in) + subroutine can_whccap(can_rhos,can_depth,wcapcan,hcapcan,ccapcan & + ,wcapcani,hcapcani,ccapcani) + use consts_coms, only : mmdry & ! intent(in) + , mmdryi ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real(kind=4), intent(in) :: can_rhos - real(kind=4), intent(in) :: can_temp - real(kind=4), intent(in) :: can_depth - real(kind=4), intent(out) :: wcapcan - real(kind=4), intent(out) :: wcapcani - real(kind=4), intent(out) :: hcapcani - real(kind=4), intent(out) :: ccapcani + real(kind=4), intent(in) :: can_rhos ! Canopy air density [ kg/m3] + real(kind=4), intent(in) :: can_depth ! Depth of canopy air space [ m] + real(kind=4), intent(out) :: wcapcan ! Water capacity - canopy air space [ kg/m2] + real(kind=4), intent(out) :: hcapcan ! Enthalpy capacity - CAS [ kg/m2] + real(kind=4), intent(out) :: ccapcan ! CO2 capacity - CAS [ mol/m2] + real(kind=4), intent(out) :: wcapcani ! Inverse of water capacity [ m2/kg] + real(kind=4), intent(out) :: hcapcani ! Inverse of enthalpy capcity [ m2/kg] + real(kind=4), intent(out) :: ccapcani ! Inverse of CO2 capacity [ m2/mol] !------------------------------------------------------------------------------------! + !----- Find the water capacity and its inverse. -------------------------------------! wcapcan = can_rhos * can_depth wcapcani = 1.0 / wcapcan - hcapcani = cpi * wcapcani / can_temp + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Because we track specific enthalpy [J/kg], the value is the same as water ! + ! capacity. ! + !------------------------------------------------------------------------------------! + hcapcan = wcapcan + hcapcani = wcapcani + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! The CO2 capacity must be in mol/m2 rather than kg/m2, since CO2 variable is in ! + ! umol/mol. ! + !------------------------------------------------------------------------------------! + ccapcan = mmdryi * wcapcan ccapcani = mmdry * wcapcani + !------------------------------------------------------------------------------------! return - end subroutine can_whcap + end subroutine can_whccap !=======================================================================================! !=======================================================================================! @@ -3348,29 +3481,47 @@ end subroutine can_whcap ! (or the canopy depth) must be allowed to change over time, so work can be done by the ! ! canopy or into the canopy. ! !---------------------------------------------------------------------------------------! - subroutine can_whcap8(can_rhos,can_temp,can_depth,wcapcan,wcapcani,hcapcani,ccapcani) - use consts_coms, only : cpi8 & ! intent(in) - , rdry8 & ! intent(in) - , ep8 & ! intent(in) - , mmdry8 ! ! intent(in) - + subroutine can_whccap8(can_rhos,can_depth,wcapcan,hcapcan,ccapcan & + ,wcapcani,hcapcani,ccapcani) + use consts_coms, only : mmdry8 & ! intent(in) + , mmdryi8 ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: can_rhos - real(kind=8), intent(in) :: can_temp - real(kind=8), intent(in) :: can_depth - real(kind=8), intent(out) :: wcapcan - real(kind=8), intent(out) :: wcapcani - real(kind=8), intent(out) :: hcapcani - real(kind=8), intent(out) :: ccapcani + real(kind=8), intent(in) :: can_rhos ! Canopy air density [ kg/m3] + real(kind=8), intent(in) :: can_depth ! Depth of canopy air space [ m] + real(kind=8), intent(out) :: wcapcan ! Water capacity - canopy air space [ kg/m2] + real(kind=8), intent(out) :: hcapcan ! Enthalpy capacity - CAS [ kg/m2] + real(kind=8), intent(out) :: ccapcan ! CO2 capacity - CAS [ mol/m2] + real(kind=8), intent(out) :: wcapcani ! Inverse of water capacity [ m2/kg] + real(kind=8), intent(out) :: hcapcani ! Inverse of enthalpy capcity [ m2/kg] + real(kind=8), intent(out) :: ccapcani ! Inverse of CO2 capacity [ m2/mol] !------------------------------------------------------------------------------------! + !----- Find the water capacity and its inverse. -------------------------------------! wcapcan = can_rhos * can_depth wcapcani = 1.d0 / wcapcan - hcapcani = cpi8 * wcapcani / can_temp + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Because we track specific enthalpy [J/kg], the value is the same as water ! + ! capacity. ! + !------------------------------------------------------------------------------------! + hcapcan = wcapcan + hcapcani = wcapcani + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! The CO2 capacity must be in mol/m2 rather than kg/m2, since CO2 variable is in ! + ! umol/mol. ! + !------------------------------------------------------------------------------------! + ccapcan = mmdryi8 * wcapcan ccapcani = mmdry8 * wcapcani + !------------------------------------------------------------------------------------! + return - end subroutine can_whcap8 + end subroutine can_whccap8 !=======================================================================================! !=======================================================================================! @@ -3395,7 +3546,7 @@ end subroutine can_whcap8 ! - gbw is in kg_H2O/m2/s. ! !---------------------------------------------------------------------------------------! subroutine leaf_aerodynamic_conductances(ipft,veg_wind,leaf_temp,can_temp,can_shv & - ,can_rhos,gbhmos_min,leaf_gbh,leaf_gbw) + ,can_rhos,can_cp,gbhmos_min,leaf_gbh,leaf_gbw) use pft_coms , only : leaf_width ! ! intent(in) use canopy_air_coms, only : aflat_lami & ! intent(in) , nflat_lami & ! intent(in) @@ -3407,8 +3558,7 @@ subroutine leaf_aerodynamic_conductances(ipft,veg_wind,leaf_temp,can_temp,can_sh , mflat_turb ! ! intent(in) use consts_coms , only : gr_coeff & ! intent(in) , th_diffi & ! intent(in) - , th_diff & ! intent(in) - , cp ! ! intent(in) + , th_diff ! ! intent(in) use physiology_coms, only : gbh_2_gbw ! ! intent(in) implicit none !----- Arguments. -------------------------------------------------------------------! @@ -3418,6 +3568,7 @@ subroutine leaf_aerodynamic_conductances(ipft,veg_wind,leaf_temp,can_temp,can_sh real(kind=4) , intent(in) :: can_temp ! Canopy air temperature [ K] real(kind=4) , intent(in) :: can_shv ! Canopy air spec. hum. [ kg/kg] real(kind=4) , intent(in) :: can_rhos ! Canopy air density [ kg/m³] + real(kind=4) , intent(in) :: can_cp ! Canopy air spec. heat [ J/kg/K] real(kind=4) , intent(in) :: gbhmos_min ! Min. Heat conductance [ m/s] real(kind=4) , intent(out) :: leaf_gbh ! Heat conductance [ J/K/m²/s] real(kind=4) , intent(out) :: leaf_gbw ! Water conductance [ kg/m²/s] @@ -3480,7 +3631,7 @@ subroutine leaf_aerodynamic_conductances(ipft,veg_wind,leaf_temp,can_temp,can_sh ! entropy and water fluxes [J/K/m²/s and kg/m²/s, respectively]. ! !------------------------------------------------------------------------------------! gbh_mos = max(gbhmos_min, free_gbh_mos + forced_gbh_mos) - leaf_gbh = gbh_mos * can_rhos * cp + leaf_gbh = gbh_mos * can_rhos * can_cp leaf_gbw = gbh_2_gbw * gbh_mos * can_rhos !------------------------------------------------------------------------------------! @@ -3510,7 +3661,7 @@ end subroutine leaf_aerodynamic_conductances ! - gbw is in kg_H2O/m2/s. ! !---------------------------------------------------------------------------------------! subroutine leaf_aerodynamic_conductances8(ipft,veg_wind,leaf_temp,can_temp,can_shv & - ,can_rhos,gbhmos_min,leaf_gbh,leaf_gbw & + ,can_rhos,can_cp,gbhmos_min,leaf_gbh,leaf_gbw & ,reynolds,grashof,nusselt_free,nusselt_forced) use pft_coms , only : leaf_width ! ! intent(in) use canopy_air_coms, only : aflat_lami8 & ! intent(in) @@ -3523,8 +3674,7 @@ subroutine leaf_aerodynamic_conductances8(ipft,veg_wind,leaf_temp,can_temp,can_s , mflat_turb8 ! ! intent(in) use consts_coms , only : gr_coeff8 & ! intent(in) , th_diffi8 & ! intent(in) - , th_diff8 & ! intent(in) - , cp8 ! ! intent(in) + , th_diff8 ! ! intent(in) use physiology_coms, only : gbh_2_gbw8 ! ! intent(in) implicit none !----- Arguments. -------------------------------------------------------------------! @@ -3534,6 +3684,7 @@ subroutine leaf_aerodynamic_conductances8(ipft,veg_wind,leaf_temp,can_temp,can_s real(kind=8) , intent(in) :: can_temp ! Canopy air temperature [ K] real(kind=8) , intent(in) :: can_shv ! Canopy air spec. hum. [ kg/kg] real(kind=8) , intent(in) :: can_rhos ! Canopy air density [ kg/m³] + real(kind=8) , intent(in) :: can_cp ! Canopy air spec. heat [ J/kg/K] real(kind=8) , intent(in) :: gbhmos_min ! Min. heat conductance [ m/s] real(kind=8) , intent(out) :: leaf_gbh ! Heat conductance [ J/K/m²/s] real(kind=8) , intent(out) :: leaf_gbw ! Water conductance [ kg/m²/s] @@ -3596,7 +3747,7 @@ subroutine leaf_aerodynamic_conductances8(ipft,veg_wind,leaf_temp,can_temp,can_s ! entropy and water fluxes [J/K/m²/s and kg/m²/s, respectively]. ! !------------------------------------------------------------------------------------! gbh_mos = max(gbhmos_min, free_gbh_mos + forced_gbh_mos) - leaf_gbh = gbh_mos * can_rhos * cp8 + leaf_gbh = gbh_mos * can_rhos * can_cp leaf_gbw = gbh_2_gbw8 * gbh_mos * can_rhos !------------------------------------------------------------------------------------! @@ -3626,7 +3777,8 @@ end subroutine leaf_aerodynamic_conductances8 ! - gbw is in kg_H2O/m2/s. ! !---------------------------------------------------------------------------------------! subroutine wood_aerodynamic_conductances(ipft,dbh,height,veg_wind,wood_temp,can_temp & - ,can_shv,can_rhos,gbhmos_min,wood_gbh,wood_gbw) + ,can_shv,can_rhos,can_cp,gbhmos_min,wood_gbh & + ,wood_gbw) use allometry , only : dbh2vol ! ! intent(in) use canopy_air_coms, only : acyli_lami & ! intent(in) , ocyli_lami & ! intent(in) @@ -3640,8 +3792,7 @@ subroutine wood_aerodynamic_conductances(ipft,dbh,height,veg_wind,wood_temp,can_ , mcyli_turb ! ! intent(in) use consts_coms , only : gr_coeff & ! intent(in) , th_diffi & ! intent(in) - , th_diff & ! intent(in) - , cp ! ! intent(in) + , th_diff ! ! intent(in) use physiology_coms, only : gbh_2_gbw ! ! intent(in) implicit none !----- Arguments. -------------------------------------------------------------------! @@ -3653,6 +3804,7 @@ subroutine wood_aerodynamic_conductances(ipft,dbh,height,veg_wind,wood_temp,can_ real(kind=4) , intent(in) :: can_temp ! Canopy air temperature [ K] real(kind=4) , intent(in) :: can_shv ! Canopy air spec. hum. [ kg/kg] real(kind=4) , intent(in) :: can_rhos ! Canopy air density [ kg/m³] + real(kind=4) , intent(in) :: can_cp ! Canopy air spec. heat [ J/kg/K] real(kind=4) , intent(in) :: gbhmos_min ! Min. Heat conductance [ m/s] real(kind=4) , intent(out) :: wood_gbh ! Heat conductance [ J/K/m²/s] real(kind=4) , intent(out) :: wood_gbw ! Water conductance [ kg/m²/s] @@ -3722,7 +3874,7 @@ subroutine wood_aerodynamic_conductances(ipft,dbh,height,veg_wind,wood_temp,can_ ! entropy and water fluxes [J/K/m²/s and kg/m²/s, respectively]. ! !------------------------------------------------------------------------------------! gbh_mos = max(gbhmos_min, free_gbh_mos + forced_gbh_mos) - wood_gbh = gbh_mos * can_rhos * cp + wood_gbh = gbh_mos * can_rhos * can_cp wood_gbw = gbh_2_gbw * gbh_mos * can_rhos !------------------------------------------------------------------------------------! @@ -3752,8 +3904,9 @@ end subroutine wood_aerodynamic_conductances ! - gbw is in kg_H2O/m2/s. ! !---------------------------------------------------------------------------------------! subroutine wood_aerodynamic_conductances8(ipft,dbh,height,veg_wind,wood_temp,can_temp & - ,can_shv,can_rhos,gbhmos_min,wood_gbh,wood_gbw & - ,reynolds,grashof,nusselt_free,nusselt_forced) + ,can_shv,can_rhos,can_cp,gbhmos_min,wood_gbh & + ,wood_gbw,reynolds,grashof,nusselt_free & + ,nusselt_forced) use allometry , only : dbh2vol ! ! intent(in) use canopy_air_coms, only : ocyli_lami8 & ! intent(in) , acyli_lami8 & ! intent(in) @@ -3767,8 +3920,7 @@ subroutine wood_aerodynamic_conductances8(ipft,dbh,height,veg_wind,wood_temp,can , mcyli_turb8 ! ! intent(in) use consts_coms , only : gr_coeff8 & ! intent(in) , th_diffi8 & ! intent(in) - , th_diff8 & ! intent(in) - , cp8 ! ! intent(in) + , th_diff8 ! ! intent(in) use physiology_coms, only : gbh_2_gbw8 ! ! intent(in) implicit none !----- Arguments. -------------------------------------------------------------------! @@ -3780,6 +3932,7 @@ subroutine wood_aerodynamic_conductances8(ipft,dbh,height,veg_wind,wood_temp,can real(kind=8) , intent(in) :: can_temp ! Canopy air temperature [ K] real(kind=8) , intent(in) :: can_shv ! Canopy air spec. hum. [ kg/kg] real(kind=8) , intent(in) :: can_rhos ! Canopy air density [ kg/m³] + real(kind=8) , intent(in) :: can_cp ! Canopy air spec. heat [ J/kg/K] real(kind=8) , intent(in) :: gbhmos_min ! Min. heat conductance [ m/s] real(kind=8) , intent(out) :: wood_gbh ! Heat conductance [ J/K/m²/s] real(kind=8) , intent(out) :: wood_gbw ! Water conductance [ kg/m²/s] @@ -3849,7 +4002,7 @@ subroutine wood_aerodynamic_conductances8(ipft,dbh,height,veg_wind,wood_temp,can ! entropy and water fluxes [J/K/m²/s and kg/m²/s, respectively]. ! !------------------------------------------------------------------------------------! gbh_mos = max(gbhmos_min, free_gbh_mos + forced_gbh_mos) - wood_gbh = gbh_mos * can_rhos * cp8 + wood_gbh = gbh_mos * can_rhos * can_cp wood_gbw = gbh_2_gbw8 * gbh_mos * can_rhos !------------------------------------------------------------------------------------! diff --git a/ED/src/dynamics/disturbance.f90 b/ED/src/dynamics/disturbance.f90 index 113fab9e7..e41d7b648 100644 --- a/ED/src/dynamics/disturbance.f90 +++ b/ED/src/dynamics/disturbance.f90 @@ -39,8 +39,9 @@ subroutine apply_disturbances(cgrid) , polygontype & ! structure , sitetype & ! structure , patchtype ! ! structure - use ed_misc_coms , only : current_time ! ! intent(in) - use disturb_coms , only : min_new_patch_area & ! intent(in) + use ed_misc_coms , only : current_time & ! intent(in) + , ibigleaf ! ! intent(in) + use disturb_coms , only : min_patch_area & ! intent(in) , mature_harvest_age & ! intent(in) , plantation_rotation & ! intent(in) , ianth_disturb & ! intent(in) @@ -51,6 +52,8 @@ subroutine apply_disturbances(cgrid) use mem_polygons , only : maxcohort ! ! intent(in) use grid_coms , only : nzg & ! intent(in) , nzs ! ! intent(in) + use pft_coms , only : include_pft ! ! intent(in) + use allometry , only : area_indices ! ! function implicit none !----- Arguments. -------------------------------------------------------------------! type(edtype) , target :: cgrid @@ -58,15 +61,26 @@ subroutine apply_disturbances(cgrid) type(polygontype) , pointer :: cpoly type(sitetype) , pointer :: csite type(sitetype) , pointer :: tsite + type(patchtype) , pointer :: cpatch type(patchtype) , pointer :: qpatch integer :: ipy integer :: isi integer :: ipa + integer :: ico + integer :: ipft + integer :: i + integer :: i1 + integer :: i2 + integer :: mypfts integer :: onsp integer :: old_lu integer :: new_lu + integer :: new_add integer :: poly_dest_type + integer, dimension(:) , allocatable :: pfts logical, dimension(:) , allocatable :: disturb_mask + logical, dimension(:) , allocatable :: acceptor_mask + logical :: have_acceptor logical :: ploughed logical :: abandoned logical :: natural @@ -83,164 +97,472 @@ subroutine apply_disturbances(cgrid) real :: dA real :: elim_nplant real :: elim_lai + real , dimension(3) :: area_old + real , dimension(3) :: area_new !------------------------------------------------------------------------------------! - !----- Allocating the temporary site that will host the original patches. -----------! - nullify(tsite) - allocate(tsite) - polyloop: do ipy = 1,cgrid%npolygons - - cpoly => cgrid%polygon(ipy) - siteloop: do isi = 1,cpoly%nsites - - csite => cpoly%site(isi) - !----- Store AGB, basal area profiles in memory. ------------------------------! - call update_site_derived_props(cpoly, 1,isi) - initial_agb(1:n_pft,1:n_dbh) = cpoly%agb(1:n_pft,1:n_dbh,isi) - initial_basal_area(1:n_pft,1:n_dbh) = cpoly%basal_area(1:n_pft,1:n_dbh,isi) - - !------------------------------------------------------------------------------! - ! First take care of harvesting, i.e., secondary -> secondary and ! - ! primary -> secondary. ! - !------------------------------------------------------------------------------! - call apply_forestry(cpoly,isi, current_time%year) - - !----- Update the cut output variables. ---------------------------------------! - call update_site_derived_props(cpoly, 1,isi) - cpoly%agb_cut(1:n_pft,1:n_dbh,isi) = cpoly%agb_cut(1:n_pft, 1:n_dbh,isi) & - + initial_agb(1:n_pft, 1:n_dbh) & - - cpoly%agb(1:n_pft, 1:n_dbh,isi) - - cpoly%basal_area_cut(1:n_pft,1:n_dbh,isi) = & + !------------------------------------------------------------------------------------! + ! Select which type of vegetation structure this run is solving. ! + !------------------------------------------------------------------------------------! + select case (ibigleaf) + case (0) + !----- Allocating the temporary site that will host the original patches. --------! + nullify(tsite) + allocate(tsite) + + polyloop: do ipy = 1,cgrid%npolygons + + cpoly => cgrid%polygon(ipy) + siteloop: do isi = 1,cpoly%nsites + + csite => cpoly%site(isi) + + !----- Store AGB, basal area profiles in memory. ---------------------------! + call update_site_derived_props(cpoly, 1,isi) + initial_agb(1:n_pft,1:n_dbh) = cpoly%agb(1:n_pft,1:n_dbh,isi) + initial_basal_area(1:n_pft,1:n_dbh) = cpoly%basal_area(1:n_pft,1:n_dbh,isi) + + !---------------------------------------------------------------------------! + ! First take care of harvesting, i.e., secondary -> secondary and ! + ! primary -> secondary. ! + !---------------------------------------------------------------------------! + call apply_forestry(cpoly,isi, current_time%year) + + !----- Update the cut output variables. ------------------------------------! + call update_site_derived_props(cpoly, 1,isi) + cpoly%agb_cut(1:n_pft,1:n_dbh,isi) = cpoly%agb_cut(1:n_pft, 1:n_dbh,isi) & + + initial_agb(1:n_pft, 1:n_dbh) & + - cpoly%agb(1:n_pft, 1:n_dbh,isi) + + cpoly%basal_area_cut(1:n_pft,1:n_dbh,isi) = & cpoly%basal_area_cut(1:n_pft,1:n_dbh,isi) & + initial_basal_area(1:n_pft,1:n_dbh) & - cpoly%basal_area(1:n_pft,1:n_dbh,isi) - !----- Save the Original Number (of) Site Patches, onsp... --------------------! - onsp = csite%npatches + !----- Save the Original Number (of) Site Patches, onsp... -----------------! + onsp = csite%npatches + + + !---------------------------------------------------------------------------! + ! Create a temporary site with vectors containing all current patches ! + ! as well as n_dist_types patches. Create the newly disturbed patches in ! + ! here, and depending on how many are created, repopulate the existing ! + ! site's patch vectors. ! + !---------------------------------------------------------------------------! + call allocate_sitetype(tsite,onsp) + + allocate(disturb_mask(onsp + n_dist_types)) + disturb_mask = .false. + disturb_mask(1:onsp) = .true. + + !---------------------------------------------------------------------------! + ! Transfer the origial patch values into the front end of the temp's ! + ! space. ! + !---------------------------------------------------------------------------! + call copy_sitetype_mask(csite,tsite,disturb_mask(1:onsp) & + ,count(disturb_mask),count(disturb_mask)) + + !----- Reallocate and transfer them back. ----------------------------------! + call deallocate_sitetype(csite) + call allocate_sitetype(csite,onsp + n_dist_types) + call copy_sitetype_mask(tsite,csite,disturb_mask(1:onsp) & + ,count(disturb_mask),count(disturb_mask)) + call deallocate_sitetype(tsite) + + + !---------------------------------------------------------------------------! + ! Initialize all the potential as well as implemented disturbance ! + ! patches. n_dist_types new patches will be created, each one containing a ! + ! different patch type. In case no conversion to that kind of patch has ! + ! happened, or if the newly created patch is tiny, it will be removed soon. ! + !---------------------------------------------------------------------------! + do new_lu = onsp+1, onsp+n_dist_types + call initialize_disturbed_patch(csite,cpoly%met(isi)%atm_tmp,new_lu,1 & + ,cpoly%lsl(isi)) + end do + !----- Loop over q, the *destination* landuse type. ------------------------! + new_lu_loop: do new_lu = 1, n_dist_types + !----- Set up area to zero, in case no conversion happens. --------------! + area = 0.0 - !------------------------------------------------------------------------------! - ! Create a temporary site with vectors containing all current patches as ! - ! well as n_dist_types patches. Create the newly disturbed patches in here, ! - ! and depending on how many are created, repopulate the existing site's patch ! - ! vectors. ! - !------------------------------------------------------------------------------! - call allocate_sitetype(tsite,onsp) + do ipa=1,onsp + !----- Save the old land use in a shorter variable for convenience. --! + old_lu = csite%dist_type(ipa) + is_plantation = csite%plantation(ipa) == 1 - allocate(disturb_mask(onsp + n_dist_types)) - disturb_mask = .false. - disturb_mask(1:onsp) = .true. + !---------------------------------------------------------------------! + ! Now we add the area associated with each kind of possible ! + ! disturbance that can happen. Types of conversion that are solved ! + ! here are: ! + ! * ploughed - conversion from primary/secondary land to agriculture.! + ! * abandoned - conversion from agriculture to secondary land. ! + ! * natural - natural disturbance from primary/secondary land to ! + ! primary land (fires or tree fall) ! + ! * logged - conversion from primary/secondary land to secondary ! + ! land due to logging. ! + !---------------------------------------------------------------------! + ploughed = new_lu == 1 .and. old_lu /= 1 + abandoned = new_lu == 2 .and. old_lu == 1 + !----- Natural disturbance, either trees are old or there is a fire. -! + natural = new_lu == 3 .and. old_lu /= 1 .and. & + ( csite%age(ipa) > time2canopy .or. & + cpoly%nat_dist_type(isi) == 1) + !----- Check whether the patch is ready be harvested. ---------------! + mature_primary = old_lu == 3 .and. & + csite%age(ipa) > mature_harvest_age + mature_plantation = is_plantation .and. & + csite%age(ipa) > plantation_rotation + mature_secondary = old_lu == 2 .and. (.not. is_plantation) .and. & + csite%age(ipa) > mature_harvest_age + !---------------------------------------------------------------------! + logged = new_lu == 2 .and. & + ( mature_primary .or. mature_plantation .or. & + mature_secondary) - !------------------------------------------------------------------------------! - ! Transfer the origial patch values into the front end of the temp's ! - ! space. ! - !------------------------------------------------------------------------------! - call copy_sitetype_mask(csite,tsite,disturb_mask(1:onsp),count(disturb_mask) & - ,count(disturb_mask)) + !---------------------------------------------------------------------! + ! Add area if any of the disturbances that produce of type new_lu ! + ! has happened. The ones that produce type other than new_lu will be ! + ! always false for new_lu. ! + !---------------------------------------------------------------------! + if (ploughed .or. abandoned .or. natural .or. logged) then + dA = csite%area(ipa) & + * (1. - exp(- ( cpoly%disturbance_rates(new_lu,old_lu,isi) & + + cpoly%disturbance_memory(new_lu,old_lu,isi) ) ) ) + area = area + dA + end if + !---------------------------------------------------------------------! - !----- Reallocate and transfer them back. -------------------------------------! - call deallocate_sitetype(csite) - call allocate_sitetype(csite,onsp + n_dist_types) - call copy_sitetype_mask(tsite,csite,disturb_mask(1:onsp),count(disturb_mask) & - ,count(disturb_mask)) - call deallocate_sitetype(tsite) + end do + + if (area > min_patch_area) then + write(unit=*,fmt='(a,1x,es12.5,1x,a,1x,i5)') & + ' ---> Making new patch, with area=',area,' for dist_type=',new_lu - !------------------------------------------------------------------------------! - ! Initialize all the potential as well as implemented disturbance ! - ! patches. n_dist_types new patches will be created, each one containing a ! - ! different patch type. In case no conversion to that kind of patch has ! - ! happened, or if the newly created patch is tiny, it will be removed soon. ! ! - !------------------------------------------------------------------------------! - do new_lu = onsp+1, onsp+n_dist_types - call initialize_disturbed_patch(csite,cpoly%met(isi)%atm_tmp,new_lu,1 & - ,cpoly%lsl(isi)) - end do + !---------------------------------------------------------------------! + ! Set the flag that this patch should be kept as a newly created ! + ! transition patch. ! + !---------------------------------------------------------------------! + disturb_mask(onsp+new_lu) = .true. + + csite%dist_type(onsp+new_lu) = new_lu + csite%plantation(onsp+new_lu) = 0 + csite%area(onsp+new_lu) = area + + !---------------------------------------------------------------------! + ! Initialize to zero the new trasitioned patches. ! + !---------------------------------------------------------------------! + call initialize_disturbed_patch(csite,cpoly%met(isi)%atm_tmp & + ,onsp+new_lu,1,cpoly%lsl(isi)) - !----- Loop over q, the *destination* landuse type. ---------------------------! - new_lu_loop: do new_lu = 1, n_dist_types - !----- Set up area to zero, in case no conversion happens. -----------------! - area = 0.0 + !---------------------------------------------------------------------! + ! Now go through patches, adding its contribution to the new ! + ! patch. ! + !---------------------------------------------------------------------! + do ipa=1,onsp + !------------------------------------------------------------------! + ! Save the old land use in a shorter variable for convenience. ! + !------------------------------------------------------------------! + old_lu = csite%dist_type(ipa) + is_plantation = csite%plantation(ipa) == 1 + + !----- Check whether this patch can be disturbed. -----------------! + ploughed = new_lu == 1 .and. old_lu /= 1 + abandoned = new_lu == 2 .and. old_lu == 1 + natural = new_lu == 3 .and. old_lu /= 1 .and. & + ( csite%age(ipa) > time2canopy .or. & + cpoly%nat_dist_type(isi) == 1) + !----- Check whether the patch is ready be harvested. ------------! + mature_primary = old_lu == 3 .and. & + csite%age(ipa) > mature_harvest_age + mature_plantation = is_plantation .and. & + csite%age(ipa) > plantation_rotation + mature_secondary = old_lu == 2 .and. (.not. is_plantation) .and. & + csite%age(ipa) > mature_harvest_age + !------------------------------------------------------------------! + logged = new_lu == 2 .and. & + ( mature_primary .or. mature_plantation .or. & + mature_secondary) + + !------------------------------------------------------------------! + ! Adjust some information to be sent to the disturbance ! + ! routine. ! + !------------------------------------------------------------------! + if (natural) then + poly_dest_type = cpoly%nat_dist_type(isi) + mindbh_harvest(1:n_pft) = huge(1.) + elseif (logged .and. mature_primary) then + poly_dest_type = 2 + mindbh_harvest(1:n_pft) = cpoly%mindbh_primary(1:n_pft,isi) + elseif (logged) then + poly_dest_type = 2 + mindbh_harvest(1:n_pft) = cpoly%mindbh_secondary(1:n_pft,isi) + else + poly_dest_type = 0 + mindbh_harvest(1:n_pft) = huge(1.) + end if + !------------------------------------------------------------------! + + + + !------------------------------------------------------------------! + ! If the patch is going to be disturbed, compute the area of ! + ! the disturbed patch to be added to the new destination patch and ! + ! update the litter layer. ! + !------------------------------------------------------------------! + if (ploughed .or. abandoned .or. natural .or. logged) then + dA = csite%area(ipa) & + * (1. - exp(- ( cpoly%disturbance_rates(new_lu,old_lu,isi) & + + cpoly%disturbance_memory(new_lu,old_lu,isi) ) ) ) + + area_fac = dA / csite%area(onsp+new_lu) + + call increment_patch_vars(csite,new_lu+onsp,ipa,area_fac) + call insert_survivors(csite,new_lu+onsp,ipa,new_lu,area_fac & + ,poly_dest_type,mindbh_harvest) + call accum_dist_litt(csite,new_lu+onsp,ipa,new_lu,area_fac & + ,poly_dest_type,mindbh_harvest) + + !----- Update patch area. --------------------------------------! + csite%area(ipa) = csite%area(ipa) - dA + end if + end do - do ipa=1,onsp - !----- Save the old land use in a shorter variable for convenience. -----! - old_lu = csite%dist_type(ipa) - is_plantation = csite%plantation(ipa) == 1 + !---------------------------------------------------------------------! + ! Update temperature and density. This must be done before ! + ! planting, since the leaf temperature is initially assigned as the ! + ! canopy air temperature. ! + !---------------------------------------------------------------------! + call update_patch_thermo_props(csite,new_lu+onsp,new_lu+onsp,nzg,nzs & + ,cpoly%ntext_soil(:,isi)) + + !----- If the new patch is agriculture, plant it with grasses. -------! + if (new_lu == 1) then + call plant_patch(csite,new_lu+onsp,nzg & + ,cpoly%agri_stocking_pft(isi) & + ,cpoly%agri_stocking_density(isi) & + ,cpoly%ntext_soil(:,isi) & + ,cpoly%green_leaf_factor(:,isi), 1.0 & + ,cpoly%lsl(isi)) + end if - !------------------------------------------------------------------------! - ! Now we add the area associated with each kind of possible disturb- ! - ! ance that can happen. Types of conversion that are solved here are: ! - ! * ploughed - conversion from primary/secondary land to agriculture. ! - ! * abandoned - conversion from agriculture to secondary land. ! - ! * natural - natural disturbance from primary/secondary land to ! - ! primary land (fires or tree fall) ! - ! * logged - conversion from primary/secondary land to secondary ! - ! land due to logging. ! - !------------------------------------------------------------------------! - ploughed = new_lu == 1 .and. old_lu /= 1 - abandoned = new_lu == 2 .and. old_lu == 1 - !----- Natural disturbance, either trees are old or there is a fire. ----! - natural = new_lu == 3 .and. old_lu /= 1 .and. & - ( csite%age(ipa) > time2canopy .or. & - cpoly%nat_dist_type(isi) == 1) - !----- Check whether the patch is ready be harvested. ------------------! - mature_primary = old_lu == 3 .and. & - csite%age(ipa) > mature_harvest_age - mature_plantation = is_plantation .and. & - csite%age(ipa) > plantation_rotation - mature_secondary = old_lu == 2 .and. (.not. is_plantation) .and. & - csite%age(ipa) > mature_harvest_age - !------------------------------------------------------------------------! - logged = new_lu == 2 .and. & - ( mature_primary .or. mature_plantation .or. & - mature_secondary) + qpatch => csite%patch(new_lu+onsp) - !------------------------------------------------------------------------! - ! Add area if any of the disturbances that produce of type new_lu has ! - ! happened. The ones that produce type other than new_lu will be always ! - ! false for new_lu. ! - !------------------------------------------------------------------------! - if (ploughed .or. abandoned .or. natural .or. logged) then - dA = csite%area(ipa) & - * (1. - exp(- ( cpoly%disturbance_rates(new_lu,old_lu,isi) & - + cpoly%disturbance_memory(new_lu,old_lu,isi) ) ) ) - area = area + dA + !----- Fuse then terminate cohorts. ----------------------------------! + if (csite%patch(new_lu+onsp)%ncohorts > 0 .and. maxcohort >= 0) then + call fuse_cohorts(csite,new_lu+onsp,cpoly%green_leaf_factor(:,isi) & + ,cpoly%lsl(isi)) + call terminate_cohorts(csite,new_lu+onsp,elim_nplant,elim_lai) + call split_cohorts(qpatch,cpoly%green_leaf_factor(:,isi) & + ,cpoly%lsl(isi)) + end if + + !----- Store AGB, basal area profiles in memory. ---------------------! + initial_agb(1:n_pft,1:n_dbh) = cpoly%agb(1:n_pft, 1:n_dbh,isi) + initial_basal_area(1:n_pft,1:n_dbh) = & + cpoly%basal_area(1:n_pft,1:n_dbh,isi) + + !---------------------------------------------------------------------! + ! Update the derived properties including veg_height, and patch- ! + ! -level LAI, WAI. ! + !---------------------------------------------------------------------! + call update_patch_derived_props( csite,cpoly%lsl(isi) & + , cpoly%met(isi)%prss & + , new_lu+onsp) + !----- Update soil temperature, liquid fraction, etc. ----------------! + call new_patch_sfc_props(csite,new_lu+onsp,nzg,nzs & + ,cpoly%ntext_soil(:,isi)) + !----- Update budget properties. -------------------------------------! + call update_budget(csite,cpoly%lsl(isi),new_lu+onsp,new_lu+onsp) + + !----- Update AGB, basal area. ---------------------------------------! + call update_site_derived_props(cpoly,1,isi) + + !----- Update either cut or mortality. -------------------------------! + if (new_lu /= 3) then + cpoly%agb_cut(1:n_pft,1:n_dbh,isi) = & + cpoly%agb_cut(1:n_pft, 1:n_dbh,isi) & + + initial_agb(1:n_pft, 1:n_dbh) & + - cpoly%agb(1:n_pft, 1:n_dbh,isi) + cpoly%basal_area_cut(1:n_pft, 1:n_dbh,isi) = & + cpoly%basal_area_cut(1:n_pft, 1:n_dbh,isi) & + + initial_basal_area(1:n_pft, 1:n_dbh) & + - cpoly%basal_area(1:n_pft, 1:n_dbh,isi) + else + cpoly%agb_mort(1:n_pft,1:n_dbh,isi) = & + cpoly%agb_mort(1:n_pft,1:n_dbh,isi) & + + initial_agb(1:n_pft,1:n_dbh) & + - cpoly%agb(1:n_pft,1:n_dbh,isi) + cpoly%basal_area_mort(1:n_pft, 1:n_dbh,isi) = & + cpoly%basal_area_mort(1:n_pft, 1:n_dbh,isi) & + + initial_basal_area(1:n_pft, 1:n_dbh) & + - cpoly%basal_area(1:n_pft, 1:n_dbh,isi) + endif + + !----- Clear the disturbance memory for this disturbance type. -------! + cpoly%disturbance_memory(new_lu,1:n_dist_types,isi) = 0.0 + + elseif(area > 0.0)then + !---------------------------------------------------------------------! + ! The patch creation has been skipped because the area was too ! + ! small. Put the current disturbance rates in memory to be added at ! + ! the next timestep. ! + !---------------------------------------------------------------------! + cpoly%disturbance_memory(new_lu,1:n_dist_types,isi) = & + cpoly%disturbance_memory(new_lu,1:n_dist_types,isi) & + + cpoly%disturbance_rates(new_lu,1:n_dist_types,isi) end if - !------------------------------------------------------------------------! + end do new_lu_loop + + !---------------------------------------------------------------------------! + ! Reallocate the current site to fit the original patches and whatever ! + ! was generated in disturbance (ie, make it non sparse). Populate the ! + ! original site with both the modified original patches, and the newly ! + ! created patches. The index of all of these are disturb_mask. This mask ! + ! should be one for all original patches, and sparse from there after. ! + !---------------------------------------------------------------------------! + call allocate_sitetype(tsite,count(disturb_mask)) + call copy_sitetype_mask(csite,tsite,disturb_mask,size(disturb_mask) & + ,count(disturb_mask)) + call deallocate_sitetype(csite) + call allocate_sitetype(csite,count(disturb_mask)) + + disturb_mask = .false. + disturb_mask(1:csite%npatches) = .true. + call copy_sitetype_mask(tsite,csite,disturb_mask(1:csite%npatches) & + ,count(disturb_mask),count(disturb_mask)) + + call deallocate_sitetype(tsite) + deallocate(disturb_mask) + !---------------------------------------------------------------------------! + + + end do siteloop + end do polyloop + + !----- Free memory before leaving... ---------------------------------------------! + deallocate(tsite) + case (1) + !---------------------------------------------------------------------------------! + ! Big leaf. ! + !---------------------------------------------------------------------------------! + !----- Allocate the temporary site that will host the original patches. ----------! + nullify (tsite) + allocate(tsite) + + polyloop2: do ipy = 1,cgrid%npolygons + + cpoly => cgrid%polygon(ipy) + siteloop2: do isi = 1,cpoly%nsites + csite => cpoly%site(isi) + !----- Store AGB, basal area profiles in memory. ---------------------------! + call update_site_derived_props(cpoly, 1,isi) + initial_agb(1:n_pft,1:n_dbh) = cpoly%agb(1:n_pft,1:n_dbh,isi) + initial_basal_area(1:n_pft,1:n_dbh) = cpoly%basal_area(1:n_pft,1:n_dbh,isi) + + !---------------------------------------------------------------------------! + ! First take care of harvesting, i.e., secondary -> secondary and ! + ! primary -> secondary. ! + !---------------------------------------------------------------------------! + call apply_forestry(cpoly,isi, current_time%year) + + !----- Update the cut output variables. ------------------------------------! + call update_site_derived_props(cpoly, 1,isi) + cpoly%agb_cut(1:n_pft,1:n_dbh,isi) = cpoly%agb_cut(1:n_pft, 1:n_dbh,isi) & + + initial_agb(1:n_pft, 1:n_dbh) & + - cpoly%agb(1:n_pft, 1:n_dbh,isi) + + cpoly%basal_area_cut(1:n_pft,1:n_dbh,isi) = & + cpoly%basal_area_cut(1:n_pft,1:n_dbh,isi) & + + initial_basal_area(1:n_pft,1:n_dbh) & + - cpoly%basal_area(1:n_pft,1:n_dbh,isi) + + !----- Save the Original Number (of) Site Patches, onsp... -----------------! + onsp = csite%npatches + + + !---------------------------------------------------------------------------! + ! Create a temporary site with vectors containing all current patches ! + ! as well as n_dist_types * mypfts patches. Create the newly disturbed ! + ! patches here and repopulate the existing site's patch vectors. ! + !---------------------------------------------------------------------------! + mypfts=count(include_pft) + allocate(pfts(mypfts)) + i1=0 + do i=1,n_pft + if (include_pft(i)) then + i1=i1+1 + pfts(i1)=i + end if + end do + call allocate_sitetype(tsite,onsp) + + allocate(disturb_mask(onsp + (n_dist_types-1) * mypfts +1 )) + disturb_mask = .false. + disturb_mask(1:onsp) = .true. + + !---------------------------------------------------------------------------! + ! Transfer the origial patch values into the front end of the temp's ! + ! space. ! + !---------------------------------------------------------------------------! + call copy_sitetype_mask(csite,tsite,disturb_mask(1:onsp) & + ,count(disturb_mask),count(disturb_mask)) + + !----- Reallocate and transfer them back. ----------------------------------! + call deallocate_sitetype(csite) + call allocate_sitetype(csite,onsp + (n_dist_types-1) * mypfts +1) + call copy_sitetype_mask(tsite,csite,disturb_mask(1:onsp) & + ,count(disturb_mask),count(disturb_mask)) + call deallocate_sitetype(tsite) + + + !---------------------------------------------------------------------------! + ! Initialize all the potential as well as implemented disturbance ! + ! patches. n_dist_types new patches will be created, each one containing a ! + ! different patch type. In case no conversion to that kind of patch has ! + ! happened, or if the newly created patch is tiny, it will be removed soon. ! + !---------------------------------------------------------------------------! + do new_lu = onsp+1, onsp+(n_dist_types-1)*mypfts+1 + call initialize_disturbed_patch(csite,cpoly%met(isi)%atm_tmp,new_lu,1 & + ,cpoly%lsl(isi)) end do - - if (area > min_new_patch_area) then - write(unit=*,fmt='(a,1x,es12.5,1x,a,1x,i5)') & - ' ---> Making new patch, with area=',area,' for dist_type=',new_lu - !------------------------------------------------------------------------! - ! Set the flag that this patch should be kept as a newly created ! - ! transition patch. ! - !------------------------------------------------------------------------! - disturb_mask(onsp+new_lu) = .true. - - csite%dist_type(onsp+new_lu) = new_lu - csite%plantation(onsp+new_lu) = 0 - csite%area(onsp+new_lu) = area - - !----- Initialize to zero the new trasitioned patches. ------------------! - call initialize_disturbed_patch(csite,cpoly%met(isi)%atm_tmp,onsp+new_lu & - ,1,cpoly%lsl(isi)) - !----- Now go through patches, adding its contribution to the new patch. ! + + !---------------------------------------------------------------------------! + ! First round, determine areas disturbanced and change the areas of the ! + ! existing patches. ! + !---------------------------------------------------------------------------! + + !----- Loop over q, the *destination* landuse type. ------------------------! + new_lu_loop2: do new_lu = 1, n_dist_types + !----- Set up area to zero, in case no conversion happens. --------------! + area = 0.0 + do ipa=1,onsp !----- Save the old land use in a shorter variable for convenience. --! old_lu = csite%dist_type(ipa) is_plantation = csite%plantation(ipa) == 1 - !----- Check whether this patch can be disturbed. --------------------! + !---------------------------------------------------------------------! + ! Now we add the area associated with each kind of possible ! + ! disturbance that can happen. Types of conversion that are solved ! + ! here are: ! + ! * ploughed - conversion from primary/secondary land to agriculture.! + ! * abandoned - conversion from agriculture to secondary land. ! + ! * natural - natural disturbance from primary/secondary land to ! + ! primary land (fires or tree fall) ! + ! * logged - conversion from primary/secondary land to secondary ! + ! land due to logging. ! + !---------------------------------------------------------------------! ploughed = new_lu == 1 .and. old_lu /= 1 abandoned = new_lu == 2 .and. old_lu == 1 + !----- Natural disturbance, either trees are old or there is a fire. -! natural = new_lu == 3 .and. old_lu /= 1 .and. & ( csite%age(ipa) > time2canopy .or. & cpoly%nat_dist_type(isi) == 1) @@ -257,159 +579,361 @@ subroutine apply_disturbances(cgrid) mature_secondary) !---------------------------------------------------------------------! - ! Adjust some information to be sent to the disturbance routine. ! + ! Add area if any of the disturbances that produce of type new_lu ! + ! has happened. The ones that produce type other than new_lu will be ! + ! always false for new_lu. ! !---------------------------------------------------------------------! - if (natural) then - poly_dest_type = cpoly%nat_dist_type(isi) - mindbh_harvest(1:n_pft) = huge(1.) - elseif (logged .and. mature_primary) then - poly_dest_type = 2 - mindbh_harvest(1:n_pft) = cpoly%mindbh_primary(1:n_pft,isi) - elseif (logged) then - poly_dest_type = 2 - mindbh_harvest(1:n_pft) = cpoly%mindbh_secondary(1:n_pft,isi) - else - poly_dest_type = 0 - mindbh_harvest(1:n_pft) = huge(1.) + if (ploughed .or. abandoned .or. natural .or. logged) then + dA = csite%area(ipa) & + * (1. - exp(- ( cpoly%disturbance_rates(new_lu,old_lu,isi) & + + cpoly%disturbance_memory(new_lu,old_lu,isi) ))) + area = area + dA end if !---------------------------------------------------------------------! + end do + + if (area > min_patch_area) then !---------------------------------------------------------------------! - ! If the patch is going to be disturbed, compute the area of the ! - ! disturbed patch to be added to the new destination patch and update ! - ! the litter layer. ! + ! Set the flag that this patch should be kept as a newly created ! + ! transition patch. ! !---------------------------------------------------------------------! - if (ploughed .or. abandoned .or. natural .or. logged) then - dA = csite%area(ipa) & - * (1. - exp(- ( cpoly%disturbance_rates(new_lu,old_lu,isi) & - + cpoly%disturbance_memory(new_lu,old_lu,isi) ) ) ) - - area_fac = dA / csite%area(onsp+new_lu) - - call increment_patch_vars(csite,new_lu+onsp,ipa,area_fac) - call insert_survivors(csite,new_lu+onsp,ipa,new_lu,area_fac & - ,poly_dest_type,mindbh_harvest) - call accum_dist_litt(csite,new_lu+onsp,ipa,new_lu,area_fac & - ,poly_dest_type,mindbh_harvest) - - !----- Update patch area. -----------------------------------------! - csite%area(ipa) = csite%area(ipa) - dA + if(new_lu == 1) then + disturb_mask(onsp+new_lu) = .true. + csite%dist_type(onsp+new_lu) = new_lu + csite%plantation(onsp+new_lu) = 0 + csite%area(onsp+new_lu) = area + !----- Initialize to zero the new trasitioned patches. ------------! + call initialize_disturbed_patch(csite,cpoly%met(isi)%atm_tmp & + ,onsp+new_lu,1,cpoly%lsl(isi)) + else + do ipft=1,mypfts + i = (new_lu-2)*mypfts+1+ipft + disturb_mask(onsp+i) = .true. + csite%dist_type(onsp+i) = new_lu + csite%plantation(onsp+i) = 0 + csite%area(onsp+i) = area / real(mypfts) + !----- Initialize to zero the new trasitioned patches. ---------! + call initialize_disturbed_patch(csite,cpoly%met(isi)%atm_tmp & + ,onsp+i,1,cpoly%lsl(isi)) + end do end if - end do + !---------------------------------------------------------------------! - !------------------------------------------------------------------------! - ! Update temperature and density. This must be done before plant- ! - ! ing, since the leaf temperature is initially assigned as the canopy ! - ! air temperature. ! - !------------------------------------------------------------------------! - call update_patch_thermo_props(csite,new_lu+onsp,new_lu+onsp,nzg,nzs & - ,cpoly%ntext_soil(:,isi)) - - !----- If the new patch is agriculture, plant it with grasses. ----------! - if (new_lu == 1) then - call plant_patch(csite,new_lu+onsp,nzg,cpoly%agri_stocking_pft(isi) & - ,cpoly%agri_stocking_density(isi) & - ,cpoly%ntext_soil(:,isi) & - ,cpoly%green_leaf_factor(:,isi), 1.0, cpoly%lsl(isi)) + + !---------------------------------------------------------------------! + ! Now go through patches, adding its contribution to the new ! + ! patch. ! + !---------------------------------------------------------------------! + do ipa=1,onsp + !------------------------------------------------------------------! + ! Save the old land use in a shorter variable for convenience. ! + !------------------------------------------------------------------! + old_lu = csite%dist_type(ipa) + is_plantation = csite%plantation(ipa) == 1 + + !----- Check whether this patch can be disturbed. -----------------! + ploughed = new_lu == 1 .and. old_lu /= 1 + abandoned = new_lu == 2 .and. old_lu == 1 + natural = new_lu == 3 .and. old_lu /= 1 .and. & + ( csite%age(ipa) > time2canopy .or. & + cpoly%nat_dist_type(isi) == 1) + !----- Check whether the patch is ready be harvested. ------------! + mature_primary = old_lu == 3 .and. & + csite%age(ipa) > mature_harvest_age + mature_plantation = is_plantation .and. & + csite%age(ipa) > plantation_rotation + mature_secondary = old_lu == 2 .and. (.not. is_plantation) .and. & + csite%age(ipa) > mature_harvest_age + !------------------------------------------------------------------! + logged = new_lu == 2 .and. & + ( mature_primary .or. mature_plantation .or. & + mature_secondary) + + !------------------------------------------------------------------! + ! Adjust some information to be sent to the disturbance ! + ! routine. ! + !------------------------------------------------------------------! + if (natural) then + poly_dest_type = cpoly%nat_dist_type(isi) + mindbh_harvest(1:n_pft) = huge(1.) + elseif (logged .and. mature_primary) then + poly_dest_type = 2 + mindbh_harvest(1:n_pft) = cpoly%mindbh_primary(1:n_pft,isi) + elseif (logged) then + poly_dest_type = 2 + mindbh_harvest(1:n_pft) = cpoly%mindbh_secondary(1:n_pft,isi) + else + poly_dest_type = 0 + mindbh_harvest(1:n_pft) = huge(1.) + end if + !------------------------------------------------------------------! + + + + !------------------------------------------------------------------! + ! If the patch is going to be disturbed, compute the area of ! + ! the disturbed patch to be added to the new destination patch and ! + ! update the litter layer. ! + !------------------------------------------------------------------! + if (ploughed) then + dA = csite%area(ipa) & + * (1. - exp(- ( cpoly%disturbance_rates(new_lu,old_lu,isi) & + + cpoly%disturbance_memory(new_lu,old_lu,isi)))) + + area_fac = dA / csite%area(onsp+new_lu) + call increment_patch_vars(csite,new_lu+onsp,ipa,area_fac) + call accum_dist_litt(csite,new_lu+onsp,ipa,new_lu,area_fac & + ,poly_dest_type,mindbh_harvest) + + !----- Update patch area. --------------------------------------! + csite%area(ipa) = csite%area(ipa) - dA + else if(abandoned .or. natural .or. logged)then + do ipft=1,mypfts + i = (new_lu-2)*mypfts+1+ipft + dA = csite%area(ipa) & + * (1. - exp(-(cpoly%disturbance_rates(new_lu,old_lu,isi) & + + cpoly%disturbance_memory(new_lu,old_lu,isi)))) + dA = dA / real(mypfts) + + area_fac = dA / csite%area(onsp+i) + call increment_patch_vars(csite,onsp+i,ipa,area_fac) + call accum_dist_litt(csite,onsp+i,ipa,new_lu,area_fac & + ,poly_dest_type,mindbh_harvest) + end do + !----- Update patch area. --------------------------------------! + csite%area(ipa) = csite%area(ipa) - dA + end if + end do + + !----- Clear the disturbance memory for this disturbance type. -------! + cpoly%disturbance_memory(new_lu,1:n_dist_types,isi) = 0.0 + + elseif(area > 0.0)then + !---------------------------------------------------------------------! + ! The patch creation has been skipped because the area was too ! + ! small. Put the current disturbance rates in memory to be added at ! + ! the next timestep. ! + !---------------------------------------------------------------------! + cpoly%disturbance_memory(new_lu,1:n_dist_types,isi) = & + cpoly%disturbance_memory(new_lu,1:n_dist_types,isi) & + + cpoly%disturbance_rates(new_lu,1:n_dist_types,isi) end if + end do new_lu_loop2 - qpatch => csite%patch(new_lu+onsp) - !----- Fuse then terminate cohorts. -------------------------------------! - if (csite%patch(new_lu+onsp)%ncohorts > 0 .and. maxcohort >= 0) then - call fuse_cohorts(csite,new_lu+onsp,cpoly%green_leaf_factor(:,isi) & - ,cpoly%lsl(isi)) - call terminate_cohorts(csite,new_lu+onsp,elim_nplant,elim_lai) - call split_cohorts(qpatch,cpoly%green_leaf_factor(:,isi) & - ,cpoly%lsl(isi)) - end if - - !----- Store AGB, basal area profiles in memory. ------------------------! - initial_agb(1:n_pft,1:n_dbh) = cpoly%agb(1:n_pft, 1:n_dbh,isi) - initial_basal_area(1:n_pft,1:n_dbh) = & - cpoly%basal_area(1:n_pft,1:n_dbh,isi) + !---------------------------------------------------------------------------! + ! Now we try to find the acceptor patch(es). If there is no one, ! + ! we create them. ! + !---------------------------------------------------------------------------! + do new_lu = 1, n_dist_types + !----- Save the old land use in a shorter variable for convenience. -----! + old_lu = csite%dist_type(ipa) + is_plantation = csite%plantation(ipa) == 1 + + !----- Check whether this patch can be disturbed. -----------------------! + ploughed = new_lu == 1 .and. old_lu /= 1 + abandoned = new_lu == 2 .and. old_lu == 1 + natural = new_lu == 3 .and. old_lu /= 1 .and. & + ( csite%age(ipa) > time2canopy .or. & + cpoly%nat_dist_type(isi) == 1) + !----- Check whether the patch is ready be harvested. ------------------! + mature_primary = old_lu == 3 .and. & + csite%age(ipa) > mature_harvest_age + mature_plantation = is_plantation .and. & + csite%age(ipa) > plantation_rotation + mature_secondary = old_lu == 2 .and. (.not. is_plantation) .and. & + csite%age(ipa) > mature_harvest_age !------------------------------------------------------------------------! - ! Update the derived properties including veg_height, and patch- ! - ! -level LAI, WAI, WPA. ! - !------------------------------------------------------------------------! - call update_patch_derived_props(csite,cpoly%lsl(isi),cpoly%met(isi)%prss & - ,new_lu+onsp) - !----- Update soil temperature, liquid fraction, etc. -------------------! - call new_patch_sfc_props(csite,new_lu+onsp,nzg,nzs & - ,cpoly%ntext_soil(:,isi)) - !----- Update budget properties. ----------------------------------------! - call update_budget(csite,cpoly%lsl(isi),new_lu+onsp,new_lu+onsp) - - !----- Update AGB, basal area. ------------------------------------------! - call update_site_derived_props(cpoly,1,isi) - - !----- Update either cut or mortality. ----------------------------------! - if (new_lu /= 3) then - cpoly%agb_cut(1:n_pft,1:n_dbh,isi) = & - cpoly%agb_cut(1:n_pft, 1:n_dbh,isi) & - + initial_agb(1:n_pft, 1:n_dbh) & - - cpoly%agb(1:n_pft, 1:n_dbh,isi) - cpoly%basal_area_cut(1:n_pft, 1:n_dbh,isi) = & - cpoly%basal_area_cut(1:n_pft, 1:n_dbh,isi) & - + initial_basal_area(1:n_pft, 1:n_dbh) & - - cpoly%basal_area(1:n_pft, 1:n_dbh,isi) - else - cpoly%agb_mort(1:n_pft,1:n_dbh,isi) = & - cpoly%agb_mort(1:n_pft,1:n_dbh,isi) & - + initial_agb(1:n_pft,1:n_dbh) & - - cpoly%agb(1:n_pft,1:n_dbh,isi) - cpoly%basal_area_mort(1:n_pft, 1:n_dbh,isi) = & - cpoly%basal_area_mort(1:n_pft, 1:n_dbh,isi) & - + initial_basal_area(1:n_pft, 1:n_dbh) & - - cpoly%basal_area(1:n_pft, 1:n_dbh,isi) - endif - - !----- Clear the disturbance memory for this disturbance type. ----------! - cpoly%disturbance_memory(new_lu,1:n_dist_types,isi) = 0.0 + logged = new_lu == 2 .and. & + ( mature_primary .or. mature_plantation .or. & + mature_secondary) - elseif(area > 0.0)then !------------------------------------------------------------------------! - ! The patch creation has been skipped because the area was too ! - ! small. Put the current disturbance rates in memory to be added at the ! - ! next timestep. ! + ! Adjust some information to be sent to the disturbance routine. ! !------------------------------------------------------------------------! - cpoly%disturbance_memory(new_lu,1:n_dist_types,isi) = & - cpoly%disturbance_memory(new_lu,1:n_dist_types,isi) & - + cpoly%disturbance_rates(new_lu,1:n_dist_types,isi) - end if - end do new_lu_loop - - !------------------------------------------------------------------------------! - ! Reallocate the current site to fit the original patches and whatever ! - ! was generated in disturbance (ie, make it non sparse). Populate the ! - ! original site with both the modified original patches, and the newly created ! - ! patches. The index of all of these are disturb_mask. This mask should be ! - ! ones for all original patches, and sparse from there after. ! - !------------------------------------------------------------------------------! - call allocate_sitetype(tsite,count(disturb_mask)) - call copy_sitetype_mask(csite,tsite,disturb_mask,size(disturb_mask) & - ,count(disturb_mask)) - call deallocate_sitetype(csite) - call allocate_sitetype(csite,count(disturb_mask)) - - disturb_mask = .false. - disturb_mask(1:csite%npatches) = .true. - call copy_sitetype_mask(tsite,csite,disturb_mask(1:csite%npatches) & - ,count(disturb_mask),count(disturb_mask)) - - call deallocate_sitetype(tsite) - deallocate(disturb_mask) - !------------------------------------------------------------------------------! - - - end do siteloop - end do polyloop + if (natural) then + poly_dest_type = cpoly%nat_dist_type(isi) + mindbh_harvest(1:n_pft) = huge(1.) + elseif (logged .and. mature_primary) then + poly_dest_type = 2 + mindbh_harvest(1:n_pft) = cpoly%mindbh_primary(1:n_pft,isi) + elseif (logged) then + poly_dest_type = 2 + mindbh_harvest(1:n_pft) = cpoly%mindbh_secondary(1:n_pft,isi) + else + poly_dest_type = 0 + mindbh_harvest(1:n_pft) = huge(1.) + end if + !------------------------------------------------------------------------! + + if(new_lu ==1)then + i1=1 + i2=1 + else + i1=(new_lu-2)*mypfts+1+1 + i2=(new_lu-2)*mypfts+1+mypfts + end if + + do i=i1,i2 + if (disturb_mask(onsp+i)) then + area_old = 0.0 + allocate(acceptor_mask(onsp)) + acceptor_mask = .false. + do ipa = 1,onsp + area_old(csite%dist_type(ipa)) = area_old(csite%dist_type(ipa)) & + + csite%area(ipa) + if ( csite%dist_type(ipa) == new_lu ) then + acceptor_mask(ipa) = .true. + end if + end do + + if (count(acceptor_mask) > 0) then + do ipa =1,onsp + if (acceptor_mask(ipa)) then + dA = csite%area(ipa) * csite%area(onsp+i) & + / area_old(new_lu) + area_fac = csite%area(ipa) / (csite%area(ipa) + dA) + call normal_patch_vars(csite,ipa,area_fac) + + area_fac = dA / (csite%area(ipa) + dA) + call increment_patch_vars(csite,ipa,i+onsp,area_fac) + call accum_dist_litt(csite,ipa,i+onsp,new_lu,area_fac & + ,poly_dest_type,mindbh_harvest) + area_fac = csite%area(ipa) / (csite%area(ipa) + dA) + cpatch=>csite%patch(ipa) + do ico=1,cpatch%ncohorts + cpatch%nplant(ico)= cpatch%nplant(ico) * area_fac + + !------ Compute all area indices needed. --------------! + call area_indices(cpatch%nplant(ico),cpatch%bleaf(ico) & + ,cpatch%bdead(ico),cpatch%balive(ico) & + ,cpatch%dbh(ico),cpatch%hite(ico) & + ,cpatch%pft(ico),cpatch%sla(ico) & + ,cpatch%lai(ico),cpatch%wai(ico) & + ,cpatch%crown_area(ico) & + ,cpatch%bsapwood(ico)) + end do + csite%area(ipa) = csite%area(ipa) / area_fac + csite%age(ipa) = csite%age(ipa) * area_fac + + disturb_mask(onsp+i) = .false. + end if + end do + else + !---------------------------------------------------------------! + ! Update temperature and density. ! + !---------------------------------------------------------------! + call update_patch_thermo_props(csite,i+onsp,i+onsp,nzg & + ,nzs,cpoly%ntext_soil(:,isi)) + + if (new_lu == 1) then + !------------------------------------------------------------! + ! If the new patch is agriculture, plant it with grasses. ! + !------------------------------------------------------------! + call plant_patch(csite,i+onsp,nzg & + ,cpoly%agri_stocking_pft(isi) & + ,cpoly%agri_stocking_density(isi) & + ,cpoly%ntext_soil(:,isi) & + ,cpoly%green_leaf_factor(:,isi), 1.0 & + ,cpoly%lsl(isi)) + write(unit=*,fmt='(a,1x,es12.5,1x,a,1x,i5,1x,a,1x,i5)') & + ' ---> Making new patch, with area=',csite%area(i+onsp) & + ,' for dist_type=',new_lu & + ,' with pft=',cpoly%agri_stocking_pft(isi) + else + call plant_patch(csite,i+onsp,nzg,pfts(i) & + ,cpoly%agri_stocking_density(isi) & + ,cpoly%ntext_soil(:,isi) & + ,cpoly%green_leaf_factor(:,isi), 1.0 & + ,cpoly%lsl(isi)) + write(unit=*,fmt='(a,1x,es12.5,1x,a,1x,i5,1x,a,1x,i5)') & + ' ---> Making new patch, with area=',csite%area(i+onsp), & + ' for dist_type=',new_lu,' with pft=',pfts(i) + end if + !---------------------------------------------------------------! + ! Update the derived properties including veg_height, and ! + ! patch--level LAI, WAI. ! + !---------------------------------------------------------------! + call update_patch_derived_props(csite,cpoly%lsl(isi) & + ,cpoly%met(isi)%prss & + ,i+onsp) + !----- Update soil temperature, liquid fraction, etc. ----------! + call new_patch_sfc_props(csite,i+onsp,nzg,nzs & + ,cpoly%ntext_soil(:,isi)) + !----- Update budget properties. -------------------------------! + call update_budget(csite,cpoly%lsl(isi),i+onsp,i+onsp) + + end if + !----- Store AGB, basal area profiles in memory. ------------------! + initial_agb(1:n_pft,1:n_dbh) = cpoly%agb(1:n_pft, 1:n_dbh,isi) + initial_basal_area(1:n_pft,1:n_dbh) = & + cpoly%basal_area(1:n_pft,1:n_dbh,isi) + + + !----- Update AGB, basal area. ------------------------------------! + call update_site_derived_props(cpoly,1,isi) + + !----- Update either cut or mortality. ----------------------------! + if (new_lu /= 3) then + cpoly%agb_cut(1:n_pft,1:n_dbh,isi) = & + cpoly%agb_cut(1:n_pft, 1:n_dbh,isi) & + + initial_agb(1:n_pft, 1:n_dbh) & + - cpoly%agb(1:n_pft, 1:n_dbh,isi) + cpoly%basal_area_cut(1:n_pft, 1:n_dbh,isi) = & + cpoly%basal_area_cut(1:n_pft, 1:n_dbh,isi) & + + initial_basal_area(1:n_pft, 1:n_dbh) & + - cpoly%basal_area(1:n_pft, 1:n_dbh,isi) + else + cpoly%agb_mort(1:n_pft,1:n_dbh,isi) = & + cpoly%agb_mort(1:n_pft,1:n_dbh,isi) & + + initial_agb(1:n_pft,1:n_dbh) & + - cpoly%agb(1:n_pft,1:n_dbh,isi) + cpoly%basal_area_mort(1:n_pft, 1:n_dbh,isi) = & + cpoly%basal_area_mort(1:n_pft, 1:n_dbh,isi) & + + initial_basal_area(1:n_pft, 1:n_dbh) & + - cpoly%basal_area(1:n_pft, 1:n_dbh,isi) + end if + + deallocate(acceptor_mask) + end if + end do + end do + !---------------------------------------------------------------------------! + ! Reallocate the current site to fit the original patches and whatever ! + ! was generated in disturbance (ie, make it non sparse). Populate the ! + ! original site with both the modified original patches, and the newly ! + ! created patches. The index of all of these are disturb_mask. This mask ! + ! should be ones for all original patches, and sparse from there after. ! + !---------------------------------------------------------------------------! + call allocate_sitetype(tsite,count(disturb_mask)) + call copy_sitetype_mask(csite,tsite,disturb_mask,size(disturb_mask) & + ,count(disturb_mask)) + call deallocate_sitetype(csite) + call allocate_sitetype(csite,count(disturb_mask)) + + disturb_mask = .false. + disturb_mask(1:csite%npatches) = .true. + call copy_sitetype_mask(tsite,csite,disturb_mask(1:csite%npatches) & + ,count(disturb_mask),count(disturb_mask)) + + call deallocate_sitetype(tsite) + deallocate(disturb_mask) + deallocate(pfts) + !---------------------------------------------------------------------------! + + + end do siteloop2 + end do polyloop2 + + !----- Free memory before leaving... ---------------------------------------------! + deallocate(tsite) - !----- Free memory before leaving... ------------------------------------------------! - deallocate(tsite) + end select + !------------------------------------------------------------------------------------! return end subroutine apply_disturbances @@ -478,7 +1002,7 @@ subroutine site_disturbance_rates(month, year, cgrid) select case (include_fire) case (0) fire_dist_rate = 0.0 - case (1,2) + case default fire_dist_rate = sum(cpoly%lambda_fire(1:12,isi)) / 12.0 end select cpoly%fire_disturbance_rate(isi) = fire_dist_rate @@ -725,6 +1249,81 @@ end subroutine initialize_disturbed_patch + !=======================================================================================! + !=======================================================================================! + ! This subroutine will re-scale some patch variables using new area fraction. ! + !---------------------------------------------------------------------------------------! + subroutine normal_patch_vars(csite,ipa, area_fac) + use ed_state_vars, only : sitetype & ! structure + , patchtype ! ! structure + use ed_max_dims , only : n_pft ! ! intent(in) + use grid_coms , only : nzg ! ! intent(in) + + + implicit none + !----- Arguments. -------------------------------------------------------------------! + type(sitetype), target :: csite + integer , intent(in) :: ipa + real , intent(in) :: area_fac + !----- Local variables. -------------------------------------------------------------! + integer :: k + !------------------------------------------------------------------------------------! + + csite%fast_soil_C (ipa) = csite%fast_soil_C (ipa) * area_fac + csite%slow_soil_C (ipa) = csite%slow_soil_C (ipa) * area_fac + csite%structural_soil_C (ipa) = csite%structural_soil_C (ipa) * area_fac + csite%structural_soil_L (ipa) = csite%structural_soil_L (ipa) * area_fac + csite%mineralized_soil_N(ipa) = csite%mineralized_soil_N(ipa) * area_fac + csite%fast_soil_N (ipa) = csite%fast_soil_N (ipa) * area_fac + csite%sum_dgd (ipa) = csite%sum_dgd (ipa) * area_fac + csite%sum_chd (ipa) = csite%sum_chd (ipa) * area_fac + csite%can_theta (ipa) = csite%can_theta (ipa) * area_fac + csite%can_theiv (ipa) = csite%can_theiv (ipa) * area_fac + csite%can_prss (ipa) = csite%can_prss (ipa) * area_fac + csite%can_shv (ipa) = csite%can_shv (ipa) * area_fac + csite%can_co2 (ipa) = csite%can_co2 (ipa) * area_fac + csite%can_depth (ipa) = csite%can_depth (ipa) * area_fac + csite%ggbare (ipa) = csite%ggbare (ipa) * area_fac + csite%ggveg (ipa) = csite%ggveg (ipa) * area_fac + csite%rough (ipa) = csite%rough (ipa) * area_fac + csite%mean_rh (ipa) = csite%mean_rh (ipa) * area_fac + csite%today_A_decomp (ipa) = csite%today_A_decomp (ipa) * area_fac + csite%today_Af_decomp (ipa) = csite%today_Af_decomp (ipa) * area_fac + csite%fsc_in (ipa) = csite%fsc_in (ipa) * area_fac + csite%ssc_in (ipa) = csite%ssc_in (ipa) * area_fac + csite%ssl_in (ipa) = csite%ssl_in (ipa) * area_fac + csite%fsn_in (ipa) = csite%fsn_in (ipa) * area_fac + csite%total_plant_nitrogen_uptake(ipa) = csite%total_plant_nitrogen_uptake(ipa) & + * area_fac + + + !----- Do the same thing for the multiple-level variables. --------------------------! + do k=1,n_pft + csite%repro (k,ipa) = csite%repro (k,ipa) * area_fac + end do + do k = 1, csite%nlev_sfcwater(ipa) + csite%sfcwater_mass (k,ipa) = csite%sfcwater_mass (k,ipa) * area_fac + csite%sfcwater_energy (k,ipa) = csite%sfcwater_energy(k,ipa) * area_fac + csite%sfcwater_depth (k,ipa) = csite%sfcwater_depth (k,ipa) * area_fac + end do + do k = 1, nzg + csite%soil_energy (k,ipa) = csite%soil_energy (k,ipa) * area_fac + csite%soil_water(k,ipa) = csite%soil_water (k,ipa) * area_fac + end do + + csite%fast_soil_C(ipa) = csite%fast_soil_C(ipa) * area_fac + csite%structural_soil_C(ipa) = csite%structural_soil_C(ipa) * area_fac + csite%structural_soil_L(ipa) = csite%structural_soil_L(ipa) * area_fac + csite%fast_soil_N(ipa) = csite%fast_soil_N(ipa) * area_fac + return + end subroutine normal_patch_vars + !=======================================================================================! + !=======================================================================================! + + + + + !=======================================================================================! !=======================================================================================! @@ -774,6 +1373,18 @@ subroutine increment_patch_vars(csite,np, cp, area_fac) csite%can_theta (np) = csite%can_theta (np) & + csite%can_theta (cp) & * area_fac + csite%can_temp (np) = csite%can_temp (np) & + + csite%can_temp (cp) & + * area_fac + csite%can_temp_pv (np) = csite%can_temp_pv (np) & + + csite%can_temp_pv (cp) & + * area_fac + csite%htry (np) = csite%htry (np) & + + csite%htry (cp) & + * area_fac + csite%hprev (np) = csite%hprev (np) & + + csite%hprev (cp) & + * area_fac csite%can_theiv (np) = csite%can_theiv (np) & + csite%can_theiv (cp) & * area_fac @@ -954,7 +1565,6 @@ subroutine insert_survivors(csite, np, cp, q, area_fac,poly_dest_type,mindbh_har !------------------------------------------------------------------------------! tpatch%lai (nco) = tpatch%lai (nco) * survival_fac tpatch%wai (nco) = tpatch%wai (nco) * survival_fac - tpatch%wpa (nco) = tpatch%wpa (nco) * survival_fac tpatch%nplant (nco) = tpatch%nplant (nco) * survival_fac tpatch%mean_gpp (nco) = tpatch%mean_gpp (nco) * survival_fac tpatch%mean_leaf_resp (nco) = tpatch%mean_leaf_resp (nco) * survival_fac @@ -974,7 +1584,6 @@ subroutine insert_survivors(csite, np, cp, q, area_fac,poly_dest_type,mindbh_har tpatch%today_gpp_max (nco) = tpatch%today_gpp_max (nco) * survival_fac tpatch%today_leaf_resp (nco) = tpatch%today_leaf_resp (nco) * survival_fac tpatch%today_root_resp (nco) = tpatch%today_root_resp (nco) * survival_fac - tpatch%Psi_open (nco) = tpatch%Psi_open (nco) * survival_fac tpatch%gpp (nco) = tpatch%gpp (nco) * survival_fac tpatch%leaf_respiration (nco) = tpatch%leaf_respiration (nco) * survival_fac tpatch%root_respiration (nco) = tpatch%root_respiration (nco) * survival_fac @@ -1238,7 +1847,7 @@ subroutine plant_patch(csite,np,mzg,pft,density,ntext_soil,green_leaf_factor , ed_biomass ! ! function use ed_max_dims , only : n_pft ! ! intent(in) use phenology_coms , only : retained_carbon_fraction ! ! intent(in) - + use phenology_aux , only : pheninit_balive_bstorage ! ! intent(in) implicit none !----- Arguments. -------------------------------------------------------------------! type(sitetype) , target :: csite @@ -1308,10 +1917,16 @@ subroutine plant_patch(csite,np,mzg,pft,density,ntext_soil,green_leaf_factor cpatch%bdead(nc) = dbh2bd(cpatch%dbh(nc),cpatch%pft(nc)) !------------------------------------------------------------------------------------! - ! Initialise the active and storage biomass scaled by the leaf drought phenology (or start with 1.0 if the plant doesn't ! - ! shed their leaves due to water stress. ! + ! Initialise the active and storage biomass scaled by the leaf drought ! + ! phenology (or start with 1.0 if the plant doesn't shed their leaves due to water ! + ! stress. ! !------------------------------------------------------------------------------------! - call pheninit_balive_bstorage(mzg,csite,np,nc,ntext_soil,green_leaf_factor) + call pheninit_balive_bstorage(mzg,cpatch%pft(nc),cpatch%krdepth(nc),cpatch%hite(nc) & + ,cpatch%dbh(nc),csite%soil_water(:,np),ntext_soil & + ,green_leaf_factor,cpatch%paw_avg(nc),cpatch%elongf(nc) & + ,cpatch%phenology_status(nc),cpatch%bleaf(nc) & + ,cpatch%broot(nc),cpatch%bsapwood(nc),cpatch%balive(nc) & + ,cpatch%bstorage(nc)) !------------------------------------------------------------------------------------! @@ -1319,8 +1934,8 @@ subroutine plant_patch(csite,np,mzg,pft,density,ntext_soil,green_leaf_factor !----- Compute all area indices needed. ---------------------------------------------! call area_indices(cpatch%nplant(nc),cpatch%bleaf(nc),cpatch%bdead(nc) & ,cpatch%balive(nc),cpatch%dbh(nc),cpatch%hite(nc),cpatch%pft(nc) & - ,cpatch%sla(nc),cpatch%lai(nc),cpatch%wpa(nc),cpatch%wai(nc) & - ,cpatch%crown_area(nc),cpatch%bsapwood(nc)) + ,cpatch%sla(nc),cpatch%lai(nc),cpatch%wai(nc),cpatch%crown_area(nc) & + ,cpatch%bsapwood(nc)) !----- Find the new basal area and above-ground biomass. ----------------------------! @@ -1330,9 +1945,11 @@ subroutine plant_patch(csite,np,mzg,pft,density,ntext_soil,green_leaf_factor ,cpatch%bsapwood(nc)) cpatch%leaf_temp(nc) = csite%can_temp(np) + cpatch%leaf_temp_pv(nc)=csite%can_temp(np) cpatch%leaf_water(nc) = 0.0 cpatch%leaf_fliq(nc) = 0.0 cpatch%wood_temp(nc) = csite%can_temp(np) + cpatch%wood_temp_pv(nc)=csite%can_temp(np) cpatch%wood_water(nc) = 0.0 cpatch%wood_fliq(nc) = 0.0 diff --git a/ED/src/dynamics/euler_driver.f90 b/ED/src/dynamics/euler_driver.f90 index 11e9e3e58..b798f24e0 100644 --- a/ED/src/dynamics/euler_driver.f90 +++ b/ED/src/dynamics/euler_driver.f90 @@ -20,12 +20,7 @@ subroutine euler_timestep(cgrid) use ed_max_dims , only : n_dbh ! ! intent(in) use soil_coms , only : soil_rough & ! intent(in) , snow_rough ! ! intent(in) - use consts_coms , only : cp & ! intent(in) - , mmdryi & ! intent(in) - , day_sec & ! intent(in) - , umol_2_kgC ! ! intent(in) - use canopy_struct_dynamics, only : canopy_turbulence8 ! ! subroutine - + use therm_lib , only : tq2enthalpy ! ! function implicit none !----- Arguments -----------------------------------------------------------------------! type(edtype) , target :: cgrid @@ -46,17 +41,19 @@ subroutine euler_timestep(cgrid) real :: leaf_flux real :: veg_tai real :: wcurr_loss2atm + real :: ecurr_netrad real :: ecurr_loss2atm real :: co2curr_loss2atm real :: wcurr_loss2drainage real :: ecurr_loss2drainage real :: wcurr_loss2runoff real :: ecurr_loss2runoff - real :: old_can_theiv + real :: old_can_enthalpy real :: old_can_shv real :: old_can_co2 real :: old_can_rhos real :: old_can_temp + real :: old_can_prss real :: fm !----- External functions. -------------------------------------------------------------! real, external :: compute_netrad @@ -107,11 +104,12 @@ subroutine euler_timestep(cgrid) !----- Save the previous thermodynamic state. ---------------------------------! - old_can_theiv = csite%can_theiv(ipa) old_can_shv = csite%can_shv(ipa) old_can_co2 = csite%can_co2(ipa) old_can_rhos = csite%can_rhos(ipa) old_can_temp = csite%can_temp(ipa) + old_can_prss = csite%can_prss(ipa) + old_can_enthalpy = tq2enthalpy(csite%can_temp(ipa),csite%can_shv(ipa),.true.) !------------------------------------------------------------------------------! @@ -119,37 +117,51 @@ subroutine euler_timestep(cgrid) !------------------------------------------------------------------------------! ! Copy the meteorological variables to the rk4site structure. ! !------------------------------------------------------------------------------! - call copy_met_2_rk4site(nzg,cmet%vels,cmet%atm_theiv,cmet%atm_theta & - ,cmet%atm_tmp,cmet%atm_shv,cmet%atm_co2,cmet%geoht & - ,cmet%exner,cmet%pcpg,cmet%qpcpg,cmet%dpcpg,cmet%prss & - ,cmet%rshort,cmet%rlong,cmet%par_beam,cmet%par_diffuse & - ,cmet%nir_beam,cmet%nir_diffuse,cmet%geoht & - ,cpoly%lsl(isi),cpoly%ntext_soil(:,isi) & - ,cpoly%green_leaf_factor(:,isi) & - ,cgrid%lon(ipy),cgrid%lat(ipy),cgrid%cosz(ipy)) + call copy_met_2_rk4site(nzg,csite%can_theta(ipa),csite%can_shv(ipa) & + ,csite%can_depth(ipa),cmet%vels,cmet%atm_theiv & + ,cmet%atm_theta,cmet%atm_tmp,cmet%atm_shv,cmet%atm_co2 & + ,cmet%geoht,cmet%exner,cmet%pcpg,cmet%qpcpg,cmet%dpcpg & + ,cmet%prss,cmet%rshort,cmet%rlong,cmet%par_beam & + ,cmet%par_diffuse,cmet%nir_beam,cmet%nir_diffuse & + ,cmet%geoht,cpoly%lsl(isi),cpoly%ntext_soil(:,isi) & + ,cpoly%green_leaf_factor(:,isi),cgrid%lon(ipy) & + ,cgrid%lat(ipy),cgrid%cosz(ipy)) + !------------------------------------------------------------------------------! + !----- Compute current storage terms. -----------------------------------------! call update_budget(csite,cpoly%lsl(isi),ipa,ipa) + !------------------------------------------------------------------------------! !------------------------------------------------------------------------------! ! Set up the integration patch. ! !------------------------------------------------------------------------------! call copy_patch_init(csite,ipa,integration_buff%initp) + !------------------------------------------------------------------------------! + + !----- Get photosynthesis, stomatal conductance, and transpiration. -----------! call canopy_photosynthesis(csite,cmet,nzg,ipa,cpoly%lsl(isi) & ,cpoly%ntext_soil(:,isi) & ,cpoly%leaf_aging_factor(:,isi) & ,cpoly%green_leaf_factor(:,isi)) + !------------------------------------------------------------------------------! + + !----- Compute root and heterotrophic respiration. ----------------------------! call soil_respiration(csite,ipa,nzg,cpoly%ntext_soil(:,isi)) + !------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------! ! Set up the remaining, carbon-dependent variables to the buffer. ! !------------------------------------------------------------------------------! call copy_patch_init_carbon(csite,ipa,integration_buff%initp) + !------------------------------------------------------------------------------! !------------------------------------------------------------------------------! @@ -160,12 +172,18 @@ subroutine euler_timestep(cgrid) ,integration_buff%dinitp,integration_buff%ytemp & ,integration_buff%yscal,integration_buff%yerr & ,integration_buff%dydx,ipa,wcurr_loss2atm & - ,ecurr_loss2atm,co2curr_loss2atm,wcurr_loss2drainage & - ,ecurr_loss2drainage,wcurr_loss2runoff & - ,ecurr_loss2runoff,nsteps) + ,ecurr_netrad,ecurr_loss2atm,co2curr_loss2atm & + ,wcurr_loss2drainage,ecurr_loss2drainage & + ,wcurr_loss2runoff,ecurr_loss2runoff,nsteps) + !------------------------------------------------------------------------------! + + !----- Add the number of steps into the step counter. -------------------------! cgrid%workload(13,ipy) = cgrid%workload(13,ipy) + real(nsteps) + !------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------! ! Update the minimum monthly temperature, based on canopy temperature. ! @@ -173,16 +191,20 @@ subroutine euler_timestep(cgrid) if (cpoly%site(isi)%can_temp(ipa) < cpoly%min_monthly_temp(isi)) then cpoly%min_monthly_temp(isi) = cpoly%site(isi)%can_temp(ipa) end if - + !------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------! ! Compute the residuals. ! !------------------------------------------------------------------------------! call compute_budget(csite,cpoly%lsl(isi),cmet%pcpg,cmet%qpcpg,ipa & - ,wcurr_loss2atm,ecurr_loss2atm,co2curr_loss2atm & - ,wcurr_loss2drainage,ecurr_loss2drainage,wcurr_loss2runoff & - ,ecurr_loss2runoff,cpoly%area(isi),cgrid%cbudget_nep(ipy) & - ,old_can_theiv,old_can_shv,old_can_co2,old_can_rhos & - ,old_can_temp) + ,wcurr_loss2atm,ecurr_netrad,ecurr_loss2atm & + ,co2curr_loss2atm,wcurr_loss2drainage,ecurr_loss2drainage & + ,wcurr_loss2runoff,ecurr_loss2runoff,cpoly%area(isi) & + ,cgrid%cbudget_nep(ipy),old_can_enthalpy,old_can_shv & + ,old_can_co2,old_can_rhos,old_can_temp,old_can_prss) + !------------------------------------------------------------------------------! end do patchloop end do siteloop end do polyloop @@ -203,18 +225,15 @@ end subroutine euler_timestep ! that most of the Euler method utilises the subroutines from Runge-Kutta. ! !------------------------------------------------------------------------------------------! subroutine integrate_patch_euler(csite,initp,dinitp,ytemp,yscal,yerr,dydx,ipa & - ,wcurr_loss2atm,ecurr_loss2atm,co2curr_loss2atm & - ,wcurr_loss2drainage,ecurr_loss2drainage,wcurr_loss2runoff & - ,ecurr_loss2runoff,nsteps) + ,wcurr_loss2atm,ecurr_netrad,ecurr_loss2atm & + ,co2curr_loss2atm,wcurr_loss2drainage,ecurr_loss2drainage & + ,wcurr_loss2runoff,ecurr_loss2runoff,nsteps) use ed_state_vars , only : sitetype & ! structure , patchtype ! ! structure use ed_misc_coms , only : dtlsm ! ! intent(in) use soil_coms , only : soil_rough & ! intent(in) , snow_rough ! ! intent(in) use canopy_air_coms , only : exar8 ! ! intent(in) - use consts_coms , only : vonk8 & ! intent(in) - , cp8 & ! intent(in) - , cpi8 ! ! intent(in) use rk4_coms , only : integration_vars & ! structure , rk4patchtype & ! structure , rk4site & ! intent(inout) @@ -237,6 +256,7 @@ subroutine integrate_patch_euler(csite,initp,dinitp,ytemp,yscal,yerr,dydx,ipa type(rk4patchtype) , target :: dydx integer , intent(in) :: ipa real , intent(out) :: wcurr_loss2atm + real , intent(out) :: ecurr_netrad real , intent(out) :: ecurr_loss2atm real , intent(out) :: co2curr_loss2atm real , intent(out) :: wcurr_loss2drainage @@ -291,9 +311,9 @@ subroutine integrate_patch_euler(csite,initp,dinitp,ytemp,yscal,yerr,dydx,ipa !---------------------------------------------------------------------------------------! ! Move the state variables from the integrated patch to the model patch. ! !---------------------------------------------------------------------------------------! - call initp2modelp(tend-tbeg,initp,csite,ipa,wcurr_loss2atm,ecurr_loss2atm & - ,co2curr_loss2atm,wcurr_loss2drainage,ecurr_loss2drainage & - ,wcurr_loss2runoff,ecurr_loss2runoff) + call initp2modelp(tend-tbeg,initp,csite,ipa,wcurr_loss2atm,ecurr_netrad & + ,ecurr_loss2atm,co2curr_loss2atm,wcurr_loss2drainage & + ,ecurr_loss2drainage,wcurr_loss2runoff,ecurr_loss2runoff) return end subroutine integrate_patch_euler @@ -348,10 +368,9 @@ subroutine euler_integ(h1,csite,initp,dinitp,ytemp,yscal,yerr,dydx,ipa,nsteps) , time ! ! intent(in) use soil_coms , only : dslz8 & ! intent(in) , runoff_time ! ! intent(in) - use consts_coms , only : cliq8 & ! intent(in) - , t3ple8 & ! intent(in) - , tsupercool8 & ! intent(in) + use consts_coms , only : t3ple8 & ! intent(in) , wdnsi8 ! ! intent(in) + use therm_lib8 , only : tl2uint8 ! ! intent(in) implicit none !----- Arguments -----------------------------------------------------------------------! type(sitetype) , target :: csite ! Current site @@ -423,7 +442,7 @@ subroutine euler_integ(h1,csite,initp,dinitp,ytemp,yscal,yerr,dydx,ipa,nsteps) !----- Get initial derivatives ------------------------------------------------------! - call leaf_derivs(initp,dinitp,csite,ipa) + call leaf_derivs(initp,dinitp,csite,ipa,h) !----- Get scalings used to determine stability -------------------------------------! call get_yscal(initp,dinitp,h,yscal,cpatch) @@ -473,7 +492,7 @@ subroutine euler_integ(h1,csite,initp,dinitp,ytemp,yscal,yerr,dydx,ipa,nsteps) errmax = 1.d-1 !----- Take the derivative of the upcoming step. ------------------------------! - call leaf_derivs(ytemp,dydx,csite,ipa) +!! call leaf_derivs(ytemp,dydx,csite,ipa) end if @@ -550,6 +569,9 @@ subroutine euler_integ(h1,csite,initp,dinitp,ytemp,yscal,yerr,dydx,ipa,nsteps) endif hnext = max(2.d0*hmin,hnext) + call leaf_derivs(ytemp,dydx,csite,ipa,hnext) + + !------ 3d. Normalise the fluxes if the user wants detailed debugging. --------! if (print_detailed) then call norm_rk4_fluxes(ytemp,h) @@ -589,13 +611,13 @@ subroutine euler_integ(h1,csite,initp,dinitp,ytemp,yscal,yerr,dydx,ipa,nsteps) ! hdid (no reason to be faster than that). ! !---------------------------------------------------------------------------------! if (simplerunoff .and. ksn >= 1) then - + if (initp%sfcwater_mass(ksn) > 0.d0 .and. & initp%sfcwater_fracliq(ksn) > 1.d-1 ) then wfreeb = min(1.d0,dtrk4*runoff_time_i) * initp%sfcwater_mass(ksn) & * (initp%sfcwater_fracliq(ksn) - 1.d-1) / 9.d-1 - qwfree = wfreeb * cliq8 * (initp%sfcwater_tempk(ksn) - tsupercool8 ) + qwfree = wfreeb * tl2uint8(initp%sfcwater_tempk(ksn),1.d0) initp%sfcwater_mass(ksn) = initp%sfcwater_mass(ksn) - wfreeb initp%sfcwater_depth(ksn) = initp%sfcwater_depth(ksn) - wfreeb * wdnsi8 diff --git a/ED/src/dynamics/events.f90 b/ED/src/dynamics/events.f90 index 67c841402..9cb8a2511 100644 --- a/ED/src/dynamics/events.f90 +++ b/ED/src/dynamics/events.f90 @@ -386,11 +386,11 @@ subroutine event_harvest(agb_frac8,bgb_frac8,fol_frac8,stor_frac8) cpatch%hite(ico) = 0.0 end if - !----- Update LAI, WPA, and WAI ------------------------------------------! + !----- Update LAI, WAI, and CAI ------------------------------------------! call area_indices(cpatch%nplant(ico),cpatch%bleaf(ico),cpatch%bdead(ico) & ,cpatch%balive(ico),cpatch%dbh(ico), cpatch%hite(ico) & ,cpatch%pft(ico),cpatch%sla(ico), cpatch%lai(ico) & - ,cpatch%wpa(ico),cpatch%wai(ico), cpatch%crown_area(ico) & + ,cpatch%wai(ico), cpatch%crown_area(ico) & ,cpatch%bsapwood(ico)) !----- Update basal area and above-ground biomass. -----------------------! @@ -575,8 +575,8 @@ subroutine event_irrigate(rval8) use ed_state_vars,only: edgrid_g, & edtype,polygontype,sitetype, & patchtype - use therm_lib, only: qtk - use consts_coms, only : cliqvlme, allivlme,cicevlme,tsupercool,wdnsi,t00 + use therm_lib, only: uint2tl,tl2uint + use consts_coms, only : wdns,wdnsi,t00 implicit none real(kind=8),intent(in) :: rval8 @@ -622,12 +622,11 @@ subroutine event_irrigate(rval8) !! note, assume irrigation water is at same temperature as soil if(csite%soil_tempk(nzg,ipa) > t00)then - ienergy = cliqvlme * (csite%soil_tempk(nzg,ipa) - tsupercool) fliq = 1.0 else - ienergy = cicevlme * csite%soil_tempk(nzg,ipa) fliq = 0.0 end if + ienergy = wdns * tl2uint(csite%soil_tempk(nzg,ipa),fliq) k = csite%nlev_sfcwater(ipa) if(k .eq. 0) then @@ -642,7 +641,7 @@ subroutine event_irrigate(rval8) + ienergy*iwater)/(csite%sfcwater_mass(k,ipa) + iwater) csite%sfcwater_mass(k,ipa) = csite%sfcwater_mass(k,ipa) + iwater csite%sfcwater_depth(k,ipa) = csite%sfcwater_depth(k,ipa) + iwater*wdnsi - call qtk(csite%sfcwater_energy(k,ipa),csite%sfcwater_tempk(k,ipa),csite%sfcwater_fracliq(k,ipa)) + call uint2tl(csite%sfcwater_energy(k,ipa),csite%sfcwater_tempk(k,ipa),csite%sfcwater_fracliq(k,ipa)) endif !! do we need to call infiltration? @@ -754,7 +753,6 @@ subroutine event_till(rval8) cpatch%bstorage(ico) = 0.0 cpatch%nplant(ico) = 0.0 cpatch%lai(ico) = 0.0 - cpatch%wpa(ico) = 0.0 cpatch%wai(ico) = 0.0 cpatch%crown_area(ico) = 0.0 cpatch%bleaf(ico) = 0.0 diff --git a/ED/src/dynamics/farq_leuning.f90 b/ED/src/dynamics/farq_leuning.f90 index af2a2480c..66dce5025 100644 --- a/ED/src/dynamics/farq_leuning.f90 +++ b/ED/src/dynamics/farq_leuning.f90 @@ -33,7 +33,7 @@ ! ! !------------------------------------------------------------------------------------------! module farq_leuning - + use therm_lib8, only : toler8 !---------------------------------------------------------------------------------------! ! This is a flag used in various sub-routines and functions and denote that we ! @@ -49,7 +49,8 @@ module farq_leuning ! so it is a good idea to use a somewhat more strict tolerance than the ones used in ! ! therm_lib8. ! !---------------------------------------------------------------------------------------! - real(kind=8), parameter :: tolerfl8 = 1.d-10 + ! real(kind=8), parameter :: tolerfl8 = 1.d-10 + real(kind=8), parameter :: tolerfl8 = toler8 !---------------------------------------------------------------------------------------! @@ -79,12 +80,10 @@ subroutine lphysiol_full(can_prss,can_rhos,can_shv,can_co2,ipft,leaf_par,leaf_te ,lint_shv,green_leaf_factor,leaf_aging_factor,llspan,vm_bar & ,leaf_gbw,A_open,A_closed,gsw_open,gsw_closed,lsfc_shv_open & ,lsfc_shv_closed,lsfc_co2_open,lsfc_co2_closed,lint_co2_open & - ,lint_co2_closed,leaf_resp,vmout,comppout,limit_flag & - ,old_st_data) + ,lint_co2_closed,leaf_resp,vmout,comppout,limit_flag) use rk4_coms , only : tiny_offset & ! intent(in) , effarea_transp ! ! intent(in) - use c34constants , only : stoma_data & ! structure - , thispft & ! intent(out) + use c34constants , only : thispft & ! intent(out) , met & ! intent(out) , aparms & ! intent(out) , stclosed & ! intent(inout) @@ -119,7 +118,6 @@ subroutine lphysiol_full(can_prss,can_rhos,can_shv,can_co2,ipft,leaf_par,leaf_te , gbh_2_gbw8 & ! intent(in) , gbw_2_gbc8 & ! intent(in) , o2_ref8 ! ! intent(in) - use therm_lib8 , only : rslif8 ! ! function use consts_coms , only : mmh2oi8 & ! intent(in) , mmh2o8 & ! intent(in) , mmdryi8 & ! intent(in) @@ -159,8 +157,6 @@ subroutine lphysiol_full(can_prss,can_rhos,can_shv,can_co2,ipft,leaf_par,leaf_te real(kind=4), intent(out) :: vmout ! Max. Rubisco capacity [µmol/m²/s] real(kind=4), intent(out) :: comppout ! GPP compensation point [ µmol/mol] integer , intent(out) :: limit_flag ! Photosyn. limit. flag [ ---] - !----- This structure save the full stomatal state for the small pert. solver. ------! - type(stoma_data), intent(inout) :: old_st_data ! Previous results. !----- External function. -----------------------------------------------------------! real(kind=4) , external :: sngloff ! Safe double -> single precision !------------------------------------------------------------------------------------! diff --git a/ED/src/dynamics/fire.f90 b/ED/src/dynamics/fire.f90 index 065e0a368..3b6374fdc 100644 --- a/ED/src/dynamics/fire.f90 +++ b/ED/src/dynamics/fire.f90 @@ -14,7 +14,8 @@ subroutine fire_frequency(cgrid) use grid_coms , only : nzg ! ! intent(in) use soil_coms , only : slz & ! intent(in) , soil & ! intent(in) - , dslz ! ! intent(in) + , dslz & ! intent(in) + , dslzi ! ! intent(in) use disturb_coms , only : include_fire & ! intent(in) , fire_dryness_threshold & ! intent(in) , fire_smoist_depth & ! intent(in) @@ -22,6 +23,7 @@ subroutine fire_frequency(cgrid) , fire_parameter ! ! intent(in) use allometry , only : ed_biomass ! ! function use consts_coms , only : wdns & ! intent(in) + , wdnsi & ! intent(in) , day_sec ! ! intent(in) implicit none !----- Arguments -----------------------------------------------------------------------! @@ -40,8 +42,13 @@ subroutine fire_frequency(cgrid) real :: ndaysi real :: normfac real :: fire_wmass_threshold + real :: fire_intensity real :: fuel + real :: avg_slmst + real :: avg_slpot real :: ignition_rate + real :: fire_scale + real :: mean_fire_intensity !---------------------------------------------------------------------------------------! !---------------------------------------------------------------------------------------! @@ -61,8 +68,9 @@ subroutine fire_frequency(cgrid) siteloop: do isi = 1,cpoly%nsites csite => cpoly%site(isi) - !----- Initialize ignition rate (a site variable). -------------------------------! - ignition_rate = 0.0 + !----- Initialize ignition rate and the mean fire intensity (site variables). ----! + ignition_rate = 0.0 + mean_fire_intensity = 0.0 !---------------------------------------------------------------------------------! patchloop: do ipa=1,csite%npatches @@ -97,6 +105,7 @@ subroutine fire_frequency(cgrid) case (0) !------ Set water mass threshold to infinity, so fires will never happen. --! fire_wmass_threshold = huge(1.) + fire_intensity = 0. !---------------------------------------------------------------------------! case (1) @@ -106,6 +115,13 @@ subroutine fire_frequency(cgrid) ! deep fires will be nearly impossible. ! !---------------------------------------------------------------------------! fire_wmass_threshold = fire_dryness_threshold * wdns + if (csite%avg_monthly_gndwater(ipa) < fire_wmass_threshold) then + fire_intensity = fire_parameter + mean_fire_intensity = mean_fire_intensity & + + fire_intensity * csite%area(ipa) + else + fire_intensity = 0.0 + end if !---------------------------------------------------------------------------! case (2) @@ -114,12 +130,64 @@ subroutine fire_frequency(cgrid) ! must have to avoid fires, using the soil properties and the soil moisture ! ! fraction threshold. ! !---------------------------------------------------------------------------! - fire_wmass_threshold = 0 + fire_wmass_threshold = 0. do k = k_fire_first, nzg nsoil = cpoly%ntext_soil(k,isi) fire_wmass_threshold = fire_wmass_threshold & + soil(nsoil)%soilfr * dslz(k) * wdns end do + if (csite%avg_monthly_gndwater(ipa) < fire_wmass_threshold) then + fire_intensity = fire_parameter + mean_fire_intensity = mean_fire_intensity & + + fire_intensity * csite%area(ipa) + else + fire_intensity = 0.0 + end if + !---------------------------------------------------------------------------! + case (3) + !---------------------------------------------------------------------------! + ! The threshold not only determines whether fires will happen, it will ! + ! also control the fire intensity. ! + !---------------------------------------------------------------------------! + fire_wmass_threshold = 0. + avg_slpot = 0. + do k = k_fire_first, nzg + nsoil = cpoly%ntext_soil(k,isi) + fire_wmass_threshold = fire_wmass_threshold & + + soil(nsoil)%soilfr * dslz(k) * wdns + end do + + if (csite%avg_monthly_gndwater(ipa) < fire_wmass_threshold) then + nsoil = cpoly%ntext_soil(nzg,isi) + !----- Find the equivalent soil moisture. -------------------------------! + avg_slmst = max( soil(nsoil)%soilcp & + , min( soil(nsoil)%slmsts & + , csite%avg_monthly_gndwater(ipa) & + / ( wdns * abs(slz(k_fire_first)) ) ) ) + !------------------------------------------------------------------------! + + + !----- Find the equivalent soil potential. ------------------------------! + avg_slpot = soil(nsoil)%slpots & + / ( avg_slmst / soil(nsoil)%slmsts ) ** soil(nsoil)%slbs + !------------------------------------------------------------------------! + + + !----- Find the scale to reduce or amplify fires. -----------------------! + fire_scale = log( avg_slpot / soil(nsoil)%slpotwp) & + / log(soil(nsoil)%slpotfr / soil(nsoil)%slpotwp) + fire_intensity = max(0.0, fire_parameter * (1.0 - fire_scale) ) + !------------------------------------------------------------------------! + + else + fire_intensity = 0.0 + end if + !---------------------------------------------------------------------------! + + !---------------------------------------------------------------------------! + ! Find the contribution of this patch to fires. ! + !---------------------------------------------------------------------------! + mean_fire_intensity = mean_fire_intensity + fire_intensity * csite%area(ipa) !---------------------------------------------------------------------------! end select !------------------------------------------------------------------------------! @@ -130,9 +198,7 @@ subroutine fire_frequency(cgrid) ! If the soil is dry, then calculate patch contribution to the ignition ! ! rate. ! !------------------------------------------------------------------------------! - if (csite%avg_monthly_gndwater(ipa) < fire_wmass_threshold) then - ignition_rate = ignition_rate + fuel * csite%area(ipa) - end if + ignition_rate = ignition_rate + fire_intensity * fuel * csite%area(ipa) !------------------------------------------------------------------------------! @@ -146,8 +212,12 @@ subroutine fire_frequency(cgrid) !----- Calculate fire disturbance rate [1/month]. --------------------------------! - cpoly%lambda_fire (current_time%month,isi) = fire_parameter * ignition_rate - cpoly%ignition_rate (isi) = ignition_rate + cpoly%lambda_fire (current_time%month,isi) = ignition_rate + if (mean_fire_intensity > 0.) then + cpoly%ignition_rate (isi) = ignition_rate / mean_fire_intensity + else + cpoly%ignition_rate (isi) = 0.0 + end if !---------------------------------------------------------------------------------! end do siteloop !------------------------------------------------------------------------------------! diff --git a/ED/src/dynamics/forestry.f90 b/ED/src/dynamics/forestry.f90 index 5768c7ed8..70c217dd8 100644 --- a/ED/src/dynamics/forestry.f90 +++ b/ED/src/dynamics/forestry.f90 @@ -15,7 +15,7 @@ subroutine apply_forestry(cpoly, isi, year) , copy_sitetype_mask ! ! subroutine use disturb_coms , only : ianth_disturb & ! intent(in) , lutime & ! intent(in) - , min_new_patch_area & ! intent(in) + , min_patch_area & ! intent(in) , plantation_year & ! intent(in) , plantation_rotation & ! intent(in) , mature_harvest_age ! ! intent(in) @@ -26,6 +26,7 @@ subroutine apply_forestry(cpoly, isi, year) , n_dbh ! ! intent(in) use grid_coms , only : nzg & ! intent(in) , nzs ! ! intent(in) + use ed_misc_coms , only : ibigleaf ! ! intent(in) implicit none !----- Arguments -----------------------------------------------------------------------! type(polygontype) , target :: cpoly @@ -162,13 +163,38 @@ subroutine apply_forestry(cpoly, isi, year) ! area for a new patch, do not harvest, and update the memory for the next year. ! !---------------------------------------------------------------------------------------! if (total_site_biomass == 0.0 .or. & - total_harvest_target <= total_site_biomass * min_new_patch_area) then + total_harvest_target <= total_site_biomass * min_patch_area) then cpoly%primary_harvest_memory(isi) = primary_harvest_target cpoly%secondary_harvest_memory(isi) = secondary_harvest_target return end if !---------------------------------------------------------------------------------------! + if (ibigleaf == 1) then + newp = csite%npatches + !------ Compute current stocks of agb in mature forests. ----------------------------! + call inventory_mat_forests(cpoly,isi,area_mature_primary,agb_mature_primary & + ,area_mature_secondary,agb_mature_secondary & + ,area_mature_plantation,agb_mature_plantation) + + !------ Compute the mature-forest harvest rates. ------------------------------------! + call mat_forest_harv_rates(agb_mature_primary,agb_mature_secondary & + ,agb_mature_plantation,primary_harvest_target & + ,secondary_harvest_target,lambda_mature_primary & + ,lambda_mature_secondary,lambda_mature_plantation & + ,harvest_deficit) + + !------ Apply harvesting to the mature stands. --------------------------------------! + call harv_mat_patches(cpoly,isi,newp,lambda_mature_primary & + ,lambda_mature_secondary,lambda_mature_plantation) + !----- Clear out the primary harvest memory. --------------------------------------! + cpoly%primary_harvest_memory(isi) = 0.0 + + !----- There still may be a deficit if we have harvested all of the patch agb. ------! + cpoly%secondary_harvest_memory(isi) = harvest_deficit + return + end if + !---------------------------------------------------------------------------------------! @@ -229,7 +255,7 @@ subroutine apply_forestry(cpoly, isi, year) ! just terminate it. ! !---------------------------------------------------------------------------------------! csite%area(newp) = total_harvested_area - if (total_harvested_area > min_new_patch_area) then + if (total_harvested_area > min_patch_area) then write(unit=*,fmt='(a,1x,i5)') 'LANDUSE YEAR =',clutime%landuse_year write(unit=*,fmt='(a,1x,es12.5)') 'LANDUSE 14 =',clutime%landuse(14) write(unit=*,fmt='(a,1x,es12.5)') 'LANDUSE 18 =',clutime%landuse(18) @@ -460,6 +486,7 @@ subroutine harv_mat_patches(cpoly,isi,newp,lambda_mature_primary , insert_survivors & ! subroutine , increment_patch_vars ! ! subroutine use ed_max_dims , only : n_pft ! ! intent(in) + use ed_misc_coms , only : ibigleaf ! ! intent(in) implicit none !----- Arguments -----------------------------------------------------------------------! @@ -474,6 +501,7 @@ subroutine harv_mat_patches(cpoly,isi,newp,lambda_mature_primary type(patchtype) , pointer :: cpatch real , dimension(n_pft) :: mindbh_harvest integer :: ipa + integer :: ico logical :: mature_plantation logical :: mature_primary logical :: mature_secondary @@ -520,21 +548,33 @@ subroutine harv_mat_patches(cpoly,isi,newp,lambda_mature_primary end if - - !------ Found a patch that is contributing to the new patch. ------------------------! - if (dA > 0.0 .and. csite%plant_ag_biomass(ipa) >= 0.01) then - csite%area(ipa) = csite%area(ipa) - dA - call increment_patch_vars(csite,newp,ipa,dA) - !---------------------------------------------------------------------------------! - ! The destination patch disturbance type was previously set to 1 (agri- ! - ! culture), but I think it should be 2 (secondary forest) - MLO. Added the ! - ! insert survivors subroutine here just to generalise, with the target biomass ! - ! the survivorship should be 0. ! - !---------------------------------------------------------------------------------! - call accum_dist_litt(csite,newp,ipa,new_lu,dA,poly_dist_type,mindbh_harvest) - end if + select case (ibigleaf) + case (0) + !------ Found a patch that is contributing to the new patch. ---------------------! + if (dA > 0.0 .and. csite%plant_ag_biomass(ipa) >= 0.01) then + csite%area(ipa) = csite%area(ipa) - dA + call increment_patch_vars(csite,newp,ipa,dA) + !------------------------------------------------------------------------------! + ! The destination patch disturbance type was previously set to 1 (agri- ! + ! culture), but I think it should be 2 (secondary forest) - MLO. Added the ! + ! insert survivors subroutine here just to generalise, with the target biomass ! + ! the survivorship should be 0. ! + !------------------------------------------------------------------------------! + call accum_dist_litt(csite,newp,ipa,new_lu,dA,poly_dist_type,mindbh_harvest) + end if + case (1) + if (dA > 0.0 .and. csite%plant_ag_biomass(ipa) >= 0.01) then + cpatch=>csite%patch(ipa) + do ico=1,cpatch%ncohorts + cpatch%nplant(ico) = cpatch%nplant(ico) * (1.0-dA/csite%area(ipa)) + end do + csite%area(ipa) = csite%area(ipa) - dA + csite%age(ipa) = csite%age(ipa) * (1.0-dA/csite%area(ipa)) + end if + end select end do + return end subroutine harv_mat_patches !==========================================================================================! @@ -687,7 +727,7 @@ subroutine norm_harv_patch(csite,newp) use ed_state_vars , only : sitetype & ! structure , patchtype ! ! structure - use disturb_coms , only : min_new_patch_area ! ! intent(in) + use disturb_coms , only : min_patch_area ! ! intent(in) use ed_max_dims , only : n_pft ! ! intent(in) use grid_coms , only : nzg & ! intent(in) , nzs ! ! intent(in) @@ -701,7 +741,7 @@ subroutine norm_harv_patch(csite,newp) !---------------------------------------------------------------------------------------! !----- Skip normalization when the patch is too small. It will be terminated soon. ----! - if (csite%area(newp) < min_new_patch_area) then + if (csite%area(newp) < min_patch_area) then return else !----- To make the values the weighted average of all contributing patches. ---------! diff --git a/ED/src/dynamics/growth_balive.f90 b/ED/src/dynamics/growth_balive.f90 index 7344ca7c7..06d8ff16a 100644 --- a/ED/src/dynamics/growth_balive.f90 +++ b/ED/src/dynamics/growth_balive.f90 @@ -237,12 +237,12 @@ subroutine dbalive_dt(cgrid, tfact) cpatch%monthly_dndt(ico) = cpatch%monthly_dndt(ico) + dndt - !----- Updating LAI, WPA, and WAI. --------------------------------------! + !----- Updating LAI, WAI, and CAI. --------------------------------------! call area_indices(cpatch%nplant(ico),cpatch%bleaf(ico) & ,cpatch%bdead(ico),cpatch%balive(ico),cpatch%dbh(ico) & ,cpatch%hite(ico) ,cpatch%pft(ico),cpatch%sla(ico) & - ,cpatch%lai(ico),cpatch%wpa(ico),cpatch%wai(ico) & - ,cpatch%crown_area(ico),cpatch%bsapwood(ico)) + ,cpatch%lai(ico),cpatch%wai(ico),cpatch%crown_area(ico) & + ,cpatch%bsapwood(ico)) !----- Update above-ground biomass. -------------------------------------! cpatch%agb(ico) = ed_biomass(cpatch%bdead(ico),cpatch%balive(ico) & diff --git a/ED/src/dynamics/heun_driver.f90 b/ED/src/dynamics/heun_driver.f90 index 3fb5faeb2..5fbcef7fd 100644 --- a/ED/src/dynamics/heun_driver.f90 +++ b/ED/src/dynamics/heun_driver.f90 @@ -20,12 +20,7 @@ subroutine heun_timestep(cgrid) use ed_max_dims , only : n_dbh ! ! intent(in) use soil_coms , only : soil_rough & ! intent(in) , snow_rough ! ! intent(in) - use consts_coms , only : cp & ! intent(in) - , mmdryi & ! intent(in) - , day_sec & ! intent(in) - , umol_2_kgC ! ! intent(in) - use canopy_struct_dynamics, only : canopy_turbulence8 ! ! subroutine - + use therm_lib , only : tq2enthalpy ! ! function implicit none !----- Arguments -----------------------------------------------------------------------! type(edtype) , target :: cgrid @@ -46,17 +41,19 @@ subroutine heun_timestep(cgrid) real :: leaf_flux real :: veg_tai real :: wcurr_loss2atm + real :: ecurr_netrad real :: ecurr_loss2atm real :: co2curr_loss2atm real :: wcurr_loss2drainage real :: ecurr_loss2drainage real :: wcurr_loss2runoff real :: ecurr_loss2runoff - real :: old_can_theiv + real :: old_can_enthalpy real :: old_can_shv real :: old_can_co2 real :: old_can_rhos real :: old_can_temp + real :: old_can_prss real :: fm !----- External functions. -------------------------------------------------------------! real, external :: compute_netrad @@ -106,11 +103,12 @@ subroutine heun_timestep(cgrid) !----- Save the previous thermodynamic state. ---------------------------------! - old_can_theiv = csite%can_theiv(ipa) - old_can_shv = csite%can_shv(ipa) - old_can_co2 = csite%can_co2(ipa) - old_can_rhos = csite%can_rhos(ipa) - old_can_temp = csite%can_temp(ipa) + old_can_shv = csite%can_shv (ipa) + old_can_co2 = csite%can_co2 (ipa) + old_can_rhos = csite%can_rhos (ipa) + old_can_temp = csite%can_temp (ipa) + old_can_prss = csite%can_prss (ipa) + old_can_enthalpy = tq2enthalpy(csite%can_temp(ipa),csite%can_shv(ipa),.true.) !------------------------------------------------------------------------------! @@ -118,50 +116,72 @@ subroutine heun_timestep(cgrid) !------------------------------------------------------------------------------! ! Copy the meteorological variables to the rk4site structure. ! !------------------------------------------------------------------------------! - call copy_met_2_rk4site(nzg,cmet%vels,cmet%atm_theiv,cmet%atm_theta & - ,cmet%atm_tmp,cmet%atm_shv,cmet%atm_co2,cmet%geoht & - ,cmet%exner,cmet%pcpg,cmet%qpcpg,cmet%dpcpg,cmet%prss & - ,cmet%rshort,cmet%rlong,cmet%par_beam,cmet%par_diffuse & - ,cmet%nir_beam,cmet%nir_diffuse,cmet%geoht & - ,cpoly%lsl(isi),cpoly%ntext_soil(:,isi) & - ,cpoly%green_leaf_factor(:,isi) & - ,cgrid%lon(ipy),cgrid%lat(ipy),cgrid%cosz(ipy)) + call copy_met_2_rk4site(nzg,csite%can_theta(ipa),csite%can_shv(ipa) & + ,csite%can_depth(ipa),cmet%vels,cmet%atm_theiv & + ,cmet%atm_theta,cmet%atm_tmp,cmet%atm_shv,cmet%atm_co2 & + ,cmet%geoht,cmet%exner,cmet%pcpg,cmet%qpcpg,cmet%dpcpg & + ,cmet%prss,cmet%rshort,cmet%rlong,cmet%par_beam & + ,cmet%par_diffuse,cmet%nir_beam,cmet%nir_diffuse & + ,cmet%geoht,cpoly%lsl(isi),cpoly%ntext_soil(:,isi) & + ,cpoly%green_leaf_factor(:,isi),cgrid%lon(ipy) & + ,cgrid%lat(ipy),cgrid%cosz(ipy)) + !------------------------------------------------------------------------------! + + !----- Compute current storage terms. -----------------------------------------! call update_budget(csite,cpoly%lsl(isi),ipa,ipa) + !------------------------------------------------------------------------------! + !------------------------------------------------------------------------------! ! Set up the integration patch. ! !------------------------------------------------------------------------------! call copy_patch_init(csite,ipa,integration_buff%initp) + !------------------------------------------------------------------------------! + + !----- Get photosynthesis, stomatal conductance, and transpiration. -----------! call canopy_photosynthesis(csite,cmet,nzg,ipa,cpoly%lsl(isi) & ,cpoly%ntext_soil(:,isi) & ,cpoly%leaf_aging_factor(:,isi) & ,cpoly%green_leaf_factor(:,isi)) + !------------------------------------------------------------------------------! + + !----- Compute root and heterotrophic respiration. ----------------------------! call soil_respiration(csite,ipa,nzg,cpoly%ntext_soil(:,isi)) + !------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------! ! Set up the remaining, carbon-dependent variables to the buffer. ! !------------------------------------------------------------------------------! call copy_patch_init_carbon(csite,ipa,integration_buff%initp) + !------------------------------------------------------------------------------! !------------------------------------------------------------------------------! ! This is the step in which the derivatives are computed, we a structure ! ! that is very similar to the Runge-Kutta, though a simpler one. ! !------------------------------------------------------------------------------! - call integrate_patch_heun(csite,ipa,wcurr_loss2atm,ecurr_loss2atm & + call integrate_patch_heun(csite,ipa,wcurr_loss2atm,ecurr_netrad,ecurr_loss2atm & ,co2curr_loss2atm,wcurr_loss2drainage & ,ecurr_loss2drainage,wcurr_loss2runoff & ,ecurr_loss2runoff,nsteps) + !------------------------------------------------------------------------------! + + !----- Add the number of steps into the step counter. -------------------------! cgrid%workload(13,ipy) = cgrid%workload(13,ipy) + real(nsteps) + !------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------! ! Update the minimum monthly temperature, based on canopy temperature. ! @@ -169,16 +189,21 @@ subroutine heun_timestep(cgrid) if (cpoly%site(isi)%can_temp(ipa) < cpoly%min_monthly_temp(isi)) then cpoly%min_monthly_temp(isi) = cpoly%site(isi)%can_temp(ipa) end if - + !------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------! ! Compute the residuals. ! !------------------------------------------------------------------------------! call compute_budget(csite,cpoly%lsl(isi),cmet%pcpg,cmet%qpcpg,ipa & - ,wcurr_loss2atm,ecurr_loss2atm,co2curr_loss2atm & - ,wcurr_loss2drainage,ecurr_loss2drainage,wcurr_loss2runoff & - ,ecurr_loss2runoff,cpoly%area(isi),cgrid%cbudget_nep(ipy) & - ,old_can_theiv,old_can_shv,old_can_co2,old_can_rhos & - ,old_can_temp) + ,wcurr_loss2atm,ecurr_netrad,ecurr_loss2atm & + ,co2curr_loss2atm,wcurr_loss2drainage,ecurr_loss2drainage & + ,wcurr_loss2runoff,ecurr_loss2runoff,cpoly%area(isi) & + ,cgrid%cbudget_nep(ipy),old_can_enthalpy,old_can_shv & + ,old_can_co2,old_can_rhos,old_can_temp,old_can_prss) + !------------------------------------------------------------------------------! end do patchloop end do siteloop end do polyloop @@ -198,18 +223,15 @@ end subroutine heun_timestep ! This subroutine will drive the integration process using the Heun method. Notice ! ! that most of the Heun method utilises the subroutines from Runge-Kutta. ! !------------------------------------------------------------------------------------------! -subroutine integrate_patch_heun(csite,ipa,wcurr_loss2atm,ecurr_loss2atm,co2curr_loss2atm & - ,wcurr_loss2drainage,ecurr_loss2drainage,wcurr_loss2runoff & - ,ecurr_loss2runoff,nsteps) +subroutine integrate_patch_heun(csite,ipa,wcurr_loss2atm,ecurr_netrad,ecurr_loss2atm & + ,co2curr_loss2atm,wcurr_loss2drainage,ecurr_loss2drainage & + ,wcurr_loss2runoff,ecurr_loss2runoff,nsteps) use ed_state_vars , only : sitetype & ! structure , patchtype ! ! structure use ed_misc_coms , only : dtlsm ! ! intent(in) use soil_coms , only : soil_rough & ! intent(in) , snow_rough ! ! intent(in) use canopy_air_coms , only : exar8 ! ! intent(in) - use consts_coms , only : vonk8 & ! intent(in) - , cp8 & ! intent(in) - , cpi8 ! ! intent(in) use rk4_coms , only : integration_vars & ! structure , integration_buff & ! structure , rk4site & ! intent(inout) @@ -226,6 +248,7 @@ subroutine integrate_patch_heun(csite,ipa,wcurr_loss2atm,ecurr_loss2atm,co2curr_ type(sitetype) , target :: csite integer , intent(in) :: ipa real , intent(out) :: wcurr_loss2atm + real , intent(out) :: ecurr_netrad real , intent(out) :: ecurr_loss2atm real , intent(out) :: co2curr_loss2atm real , intent(out) :: wcurr_loss2drainage @@ -286,7 +309,7 @@ subroutine integrate_patch_heun(csite,ipa,wcurr_loss2atm,ecurr_loss2atm,co2curr_ ! Move the state variables from the integrated patch to the model patch. ! !---------------------------------------------------------------------------------------! call initp2modelp(tend-tbeg,integration_buff%initp,csite,ipa,wcurr_loss2atm & - ,ecurr_loss2atm,co2curr_loss2atm,wcurr_loss2drainage & + ,ecurr_netrad,ecurr_loss2atm,co2curr_loss2atm,wcurr_loss2drainage & ,ecurr_loss2drainage,wcurr_loss2runoff,ecurr_loss2runoff) return @@ -342,10 +365,9 @@ subroutine heun_integ(h1,csite,ipa,nsteps) , time ! ! intent(in) use soil_coms , only : dslz8 & ! intent(in) , runoff_time ! ! intent(in) - use consts_coms , only : cliq8 & ! intent(in) - , t3ple8 & ! intent(in) - , tsupercool8 & ! intent(in) + use consts_coms , only : t3ple8 & ! intent(in) , wdnsi8 ! ! intent(in) + use therm_lib8 , only : tl2uint8 ! ! intent(in) implicit none !----- Arguments -----------------------------------------------------------------------! type(sitetype) , target :: csite ! Current site @@ -417,7 +439,7 @@ subroutine heun_integ(h1,csite,ipa,nsteps) !----- Get initial derivatives ------------------------------------------------------! - call leaf_derivs(integration_buff%y,integration_buff%dydx,csite,ipa) + call leaf_derivs(integration_buff%y,integration_buff%dydx,csite,ipa,-9000.d0) !----- Get scalings used to determine stability -------------------------------------! call get_yscal(integration_buff%y,integration_buff%dydx,h,integration_buff%yscal & @@ -613,8 +635,7 @@ subroutine heun_integ(h1,csite,ipa,nsteps) wfreeb = min(1.d0,dtrk4*runoff_time_i) & * integration_buff%y%sfcwater_mass(ksn) & * (integration_buff%y%sfcwater_fracliq(ksn) - 1.d-1) / 9.d-1 - qwfree = wfreeb * cliq8 & - * (integration_buff%y%sfcwater_tempk(ksn) - tsupercool8 ) + qwfree = wfreeb * tl2uint8(integration_buff%y%sfcwater_tempk(ksn),1.d0) integration_buff%y%sfcwater_mass(ksn) = & integration_buff%y%sfcwater_mass(ksn) - wfreeb @@ -777,7 +798,7 @@ subroutine heun_stepper(x,h,csite,ipa,reject_step,reject_result) ! Compute the second term (correction) of the derivative, using the Euler's ! ! predicted state. ! !---------------------------------------------------------------------------------------! - call leaf_derivs(integration_buff%ak3,integration_buff%ak2, csite,ipa) + call leaf_derivs(integration_buff%ak3,integration_buff%ak2, csite,ipa,-9000.d0) !---------------------------------------------------------------------------------------! diff --git a/ED/src/dynamics/hybrid_driver.f90 b/ED/src/dynamics/hybrid_driver.f90 new file mode 100644 index 000000000..f2d4a84dd --- /dev/null +++ b/ED/src/dynamics/hybrid_driver.f90 @@ -0,0 +1,1921 @@ +!=============================================================================! +!=============================================================================! +! This subroutine is the main driver for the Forward/Backward (FB) +! Euler integration scheme. ! +!-----------------------------------------------------------------------------! +subroutine hybrid_timestep(cgrid) + use rk4_coms , only : integration_vars & ! structure + , rk4patchtype & ! structure + , zero_rk4_patch & ! subroutine + , zero_rk4_cohort & ! subroutine + , zero_bdf2_patch & + , integration_buff & ! intent(out) + , rk4site & ! intent(out) + , bdf2patchtype & + , tbeg & + , tend & + , dtrk4 & + , dtrk4i + use rk4_driver , only : initp2modelp + + use ed_state_vars , only : edtype & ! structure + , polygontype & ! structure + , sitetype & ! structure + , patchtype ! ! structure + + use met_driver_coms , only : met_driv_state ! ! structure + use grid_coms , only : nzg & ! intent(in) + , nzs ! ! intent(in) + use ed_misc_coms , only : dtlsm ! ! intent(in) + + + implicit none + !----- Arguments ----------------------------------------------------------! + type(edtype) , target :: cgrid + !----- Local variables ----------------------------------------------------! + type(polygontype) , pointer :: cpoly + type(sitetype) , pointer :: csite + type(patchtype) , pointer :: cpatch + type(met_driv_state) , pointer :: cmet + type(rk4patchtype) , pointer :: initp + type(rk4patchtype) , pointer :: dinitp + type(rk4patchtype) , pointer :: ytemp + type(bdf2patchtype) , pointer :: yprev + integer :: ipy + integer :: isi + integer :: ipa + integer :: ico + integer :: nsteps + real :: thetaatm + real :: thetacan + real :: rasveg + real :: storage_decay + real :: leaf_flux + real :: veg_tai + real :: wcurr_loss2atm + real :: ecurr_loss2atm + real :: co2curr_loss2atm + real :: ecurr_netrad + real :: wcurr_loss2drainage + real :: ecurr_loss2drainage + real :: wcurr_loss2runoff + real :: ecurr_loss2runoff + real :: old_can_theiv + real :: old_can_shv + real :: old_can_co2 + real :: old_can_rhos + real :: old_can_temp + real :: old_can_prss + real :: old_can_enthalpy + real :: fm + real :: wtime0 + real(kind=8) :: hbeg + logical , save :: first_time=.true. + + !----- External functions. -------------------------------------------------------------! + real, external :: compute_netrad + real, external :: walltime + !---------------------------------------------------------------------------------------! + + initp => integration_buff%initp + ytemp => integration_buff%ytemp + dinitp => integration_buff%dinitp + yprev => integration_buff%yprev + + + !- Assigning some constants which will remain the same throughout ! + ! the run. ----! + if (first_time) then + first_time = .false. + tbeg = 0.d0 + tend = dble(dtlsm) + dtrk4 = tend - tbeg + dtrk4i = 1.d0/dtrk4 + end if + + polyloop: do ipy = 1,cgrid%npolygons + cpoly => cgrid%polygon(ipy) + + wtime0=walltime(0.) + + siteloop: do isi = 1,cpoly%nsites + csite => cpoly%site(isi) + cmet => cpoly%met(isi) + + patchloop: do ipa = 1,csite%npatches + cpatch => csite%patch(ipa) + + !----- Reset all buffers to zero, as a safety measure. ------------! + call zero_rk4_patch(initp) + call zero_rk4_patch(ytemp) + call zero_rk4_patch(dinitp) + call zero_bdf2_patch(yprev) + + call zero_rk4_cohort(initp) + call zero_rk4_cohort(ytemp) + call zero_rk4_cohort(dinitp) + + !----- Get velocity for aerodynamic resistance. -------------------! + if (csite%can_theta(ipa) < cmet%atm_theta) then + cmet%vels = cmet%vels_stab + else + cmet%vels = cmet%vels_unstab + end if + !------------------------------------------------------------------! + + !------------------------------------------------------------------! + ! Update roughness and canopy depth. ! + !------------------------------------------------------------------! + call update_patch_thermo_props(csite,ipa,ipa,nzg,nzs,& + cpoly%ntext_soil(:,isi)) + call update_patch_derived_props(csite,cpoly%lsl(isi),cmet%prss,ipa) + !------------------------------------------------------------------! + + !----- Save the previous thermodynamic state. ---------------------! + old_can_shv = csite%can_shv(ipa) + old_can_co2 = csite%can_co2(ipa) + old_can_rhos = csite%can_rhos(ipa) + old_can_temp = csite%can_temp(ipa) + !------------------------------------------------------------------! + + !------------------------------------------------------------------! + ! Copy the meteorological variables to the rk4site structure. ! + !------------------------------------------------------------------! + call copy_met_2_rk4site(nzg,csite%can_theta(ipa),csite%can_shv(ipa)& + ,csite%can_depth(ipa),cmet%vels,cmet%atm_theiv & + ,cmet%atm_theta,cmet%atm_tmp,cmet%atm_shv,cmet%atm_co2 & + ,cmet%geoht,cmet%exner,cmet%pcpg,cmet%qpcpg,cmet%dpcpg & + ,cmet%prss,cmet%rshort,cmet%rlong,cmet%par_beam & + ,cmet%par_diffuse,cmet%nir_beam,cmet%nir_diffuse & + ,cmet%geoht,cpoly%lsl(isi),cpoly%ntext_soil(:,isi) & + ,cpoly%green_leaf_factor(:,isi),cgrid%lon(ipy) & + ,cgrid%lat(ipy),cgrid%cosz(ipy)) + + + !----- Compute current storage terms. -----------------------------! + call update_budget(csite,cpoly%lsl(isi),ipa,ipa) + + + !------------------------------------------------------------------! + ! Set up the integration patch. ! + !------------------------------------------------------------------! + call copy_patch_init(csite,ipa,initp) + + !------------------------------------------------------------------! + ! Set up the buffer for the previous step's leaf temperature ! + !------------------------------------------------------------------! + call copy_bdf2_prev(csite,ipa,yprev) + + !----- Get photosynthesis, stomatal conductance, + ! and transpiration. -----------! + call canopy_photosynthesis(csite,cmet,nzg,ipa,cpoly%lsl(isi), & + cpoly%ntext_soil(:,isi),cpoly%leaf_aging_factor(:,isi), & + cpoly%green_leaf_factor(:,isi)) + + !----- Compute root and heterotrophic respiration. ----------------! + call soil_respiration(csite,ipa,nzg,cpoly%ntext_soil(:,isi)) + + !------------------------------------------------------------------! + ! Set up the remaining, carbon-dependent variables to the buffer. ! + !------------------------------------------------------------------! + call copy_patch_init_carbon(csite,ipa,initp) + + !------------------------------------------------------------------! + ! Perform the forward and backward step. It is possible this will! + ! be done over a series of sub-steps. 1)derivs,2)forward,3)back ! + ! 4) check stability and error 5) repeat as shorter or continue ! + !------------------------------------------------------------------! +! call integrate_patch_hybrid(csite, & +! integration_buff%yprev,integration_buff%initp, & +! integration_buff%dinitp,integration_buff%ytemp, & +! ipa,wcurr_loss2atm, & +! ecurr_loss2atm,co2curr_loss2atm,wcurr_loss2drainage, & +! ecurr_loss2drainage,wcurr_loss2runoff, & +! ecurr_loss2runoff,ecurr_netrad,nsteps) + + + + + !--------------------------------------------------------------------------! + ! Initial step size. Experience has shown that giving this too large a ! + ! value causes the integrator to fail (e.g., soil layers become ! + ! supersaturated). ! + !--------------------------------------------------------------------------! + hbeg = dble(csite%htry(ipa)) + + !--------------------------------------------------------------------------! + ! Zero the canopy-atmosphere flux values. These values are updated ! + ! every dtlsm, so they must be zeroed at each call. ! + !--------------------------------------------------------------------------! + initp%upwp = 0.d0 + initp%tpwp = 0.d0 + initp%qpwp = 0.d0 + initp%cpwp = 0.d0 + initp%wpwp = 0.d0 + + !----- Go into the ODE integrator using Euler. ----------------------------! + + call hybrid_integ(hbeg,csite,yprev,initp,dinitp, & + ytemp,ipa,nsteps) + + !--------------------------------------------------------------------------! + ! Normalize canopy-atmosphere flux values. These values are updated ever ! + ! dtlsm, so they must be normalized every time. ! + !--------------------------------------------------------------------------! + initp%upwp = initp%can_rhos * initp%upwp * dtrk4i + initp%tpwp = initp%can_rhos * initp%tpwp * dtrk4i + initp%qpwp = initp%can_rhos * initp%qpwp * dtrk4i + initp%cpwp = initp%can_rhos * initp%cpwp * dtrk4i + initp%wpwp = initp%can_rhos * initp%wpwp * dtrk4i + + !--------------------------------------------------------------------------! + ! Move the state variables from the integrated patch to the model patch. ! + !--------------------------------------------------------------------------! + + call initp2modelp(tend-tbeg,initp,csite,ipa,wcurr_loss2atm,ecurr_netrad & + ,ecurr_loss2atm,co2curr_loss2atm,wcurr_loss2drainage & + ,ecurr_loss2drainage,wcurr_loss2runoff,ecurr_loss2runoff) + + + !----- Add the number of steps into the step counter. -------------! + cgrid%workload(13,ipy) = cgrid%workload(13,ipy) + real(nsteps) + + !------------------------------------------------------------------! + ! Update the minimum monthly temperature, ! + ! based on canopy temperature. ! + !------------------------------------------------------------------! + if (cpoly%site(isi)%can_temp(ipa) < cpoly%min_monthly_temp(isi)) then + cpoly%min_monthly_temp(isi) = cpoly%site(isi)%can_temp(ipa) + end if + + !------------------------------------------------------------------! + ! Compute the residuals. ! + !------------------------------------------------------------------! + + call compute_budget(csite,cpoly%lsl(isi),cmet%pcpg,cmet%qpcpg,ipa & + ,wcurr_loss2atm,ecurr_netrad,ecurr_loss2atm & + ,co2curr_loss2atm,wcurr_loss2drainage,ecurr_loss2drainage & + ,wcurr_loss2runoff,ecurr_loss2runoff,cpoly%area(isi) & + ,cgrid%cbudget_nep(ipy),old_can_enthalpy,old_can_shv & + ,old_can_co2,old_can_rhos,old_can_temp,old_can_prss) + + end do patchloop + end do siteloop + + cgrid%walltime_py(ipy) = cgrid%walltime_py(ipy)+walltime(wtime0) + + end do polyloop + + return + end subroutine hybrid_timestep + !============================================================================! + !============================================================================! + + + !============================================================================! + !============================================================================! + ! This subroutine will drive the integration of several ODEs that drive ! + ! the fast-scale state variables. ! + !----------------------------------------------------------------------------! + subroutine hybrid_integ(h1,csite,yprev,initp,dinitp,ytemp,ipa,nsteps) + + use ed_state_vars , only : sitetype & ! structure + , patchtype ! structure + use rk4_coms , only : integration_vars & ! structure + , rk4patchtype & ! structure + , bdf2patchtype & ! structure + , rk4site & ! intent(in) + , print_diags & ! intent(in) + , maxstp & ! intent(in) + , tbeg & ! intent(in) + , tend & ! intent(in) + , dtrk4 & ! intent(in) + , dtrk4i & ! intent(in) + , tiny_offset & ! intent(in) + , checkbudget & ! intent(in) + , zero_rk4_patch & ! subroutine + , zero_rk4_cohort & ! subroutine + , hmin & ! intent(in) + , rk4eps & ! intent(in) + , rk4epsi & ! intent(in) + , safety & ! intent(in) + , pgrow & ! intent(in) + , pshrnk & ! intent(in) + , errcon & ! intent(in) + , print_detailed & ! intent(in) + , norm_rk4_fluxes & ! sub-routine + , reset_rk4_fluxes ! ! sub-routine + use rk4_stepper , only : rk4_sanity_check & ! subroutine + , print_sanity_check ! ! subroutine + use ed_misc_coms , only : fast_diagnostics ! ! intent(in) + use hydrology_coms , only : useRUNOFF ! ! intent(in) + use grid_coms , only : nzg & ! intent(in) + , nzs & ! intent(in) + , time ! ! intent(in) + use soil_coms , only : dslz8 & ! intent(in) + , runoff_time ! ! intent(in) + use consts_coms , only : cliq8 & ! intent(in) + , t3ple8 & ! intent(in) + , tsupercool_liq8 & ! intent(in) + , wdnsi8 ! ! intent(in) + implicit none + !----- Arguments ----------------------------------------------------------! + type(sitetype) , target :: csite ! Current site + + type(rk4patchtype) , target :: initp ! Current integ. patch + type(rk4patchtype) , target :: dinitp ! Integration derivative + type(rk4patchtype) , target :: ytemp ! Patch at n+1 + type(bdf2patchtype) , target :: yprev ! Patch at n-1 + + integer , intent(in) :: ipa ! Current patch ID + real(kind=8) , intent(in) :: h1 ! First guess of delta-t + integer , intent(out) :: nsteps ! Number of steps taken. + !----- Local variables ----------------------------------------------------! + type(patchtype) , pointer :: cpatch ! Current patch + logical :: restart_step + logical :: reject_step + logical :: minstep + logical :: stuck + logical :: test_reject + integer :: i + integer :: k ! Format counter + integer :: ksn ! # of snow/water + ! layers + real(kind=8) :: x ! Elapsed time + real(kind=8) :: xnew ! Elapsed time + h + real(kind=8) :: newh ! New time step + ! suggested + real(kind=8) :: oldh ! Old time step + real(kind=8) :: h ! Current delta-t + ! attempt + real(kind=8) :: htrunc + real(kind=8) :: hnext ! Next delta-t + real(kind=8) :: hdid ! delta-t that + ! worked (???) + real(kind=8) :: qwfree ! Free water + ! internal energy + real(kind=8) :: wfreeb ! Free water + real(kind=8) :: errmax ! Maximum error + ! of this step + real(kind=8) :: elaptime ! Absolute elapsed + ! time. + integer :: nsolve ! Size of a badger + !----- Saved variables ----------------------------------------------------! + logical , save :: first_time=.true. + logical , save :: simplerunoff + real(kind=8) , save :: runoff_time_i + !----- External function. -------------------------------------------------! + real , external :: sngloff + !--------------------------------------------------------------------------! + + !----- Checking whether we will use runoff or not, ! + ! and saving this check to save time. -! + if (first_time) then + simplerunoff = useRUNOFF == 0 .and. runoff_time /= 0. + + if (runoff_time /= 0.) then + runoff_time_i = 1.d0/dble(runoff_time) + else + runoff_time_i = 0.d0 + end if + first_time = .false. + end if + + !----- Use some aliases for simplicity. -----------------------------------! + cpatch => csite%patch(ipa) + + !--------------------------------------------------------------------------! + ! Set initial time and stepsize. ! + !--------------------------------------------------------------------------! + x = tbeg + h = h1 + if (dtrk4 < 0.d0) h = -h1 + + !----- Define total elapsed time. -----------------------------------------! + elaptime = time + x + + + !--------------------------------------------------------------------------! + ! Begin timestep loop ! + !--------------------------------------------------------------------------! + timesteploop: do i=1,maxstp + + !----- Be sure not to overstep -----------------------------------------! + if((x+h-tend)*(x+h-tbeg) > 0.d0) h=tend-x + + reject_step = .false. + hstep: do + + + call leaf_derivs(initp,dinitp,csite,ipa,h) + + + !---------------------------------------------------------------------! + ! Error analysis. Two parts. First leaf/air/step then surface ! + !---------------------------------------------------------------------! + call fb_dy_step_trunc(initp,restart_step,csite,ipa,dinitp,h,htrunc) + + if (restart_step) then + + oldh = h + newh = htrunc + minstep = (newh == h) .or. newh < hmin + + if(minstep)then + + call fail_whale("hybrid euler truncation converged",& + "fb_euler_integ") + print*,htrunc,h + stop + end if + + !----- Defining next time, and checking if it really added something. ! + h = max(1.d-1*h, newh) + xnew = x + h + stuck = xnew == x + + cycle + end if + + !--------------------------------------------------------------------! + ! Copy patch to the temporary structure ! + ! Note that this routine also calculates the size of the matrix ! + ! used in the implicit step. ! + ! nsolve = 1 + n_leaf_cohorts + n_wood_cohorts ! + !--------------------------------------------------------------------! + call copy_fb_patch(initp,ytemp,cpatch,nsolve) + + !--------------------------------------------------------------------! + ! Integrate the forward step ! + !--------------------------------------------------------------------! + call inc_fwd_patch(ytemp,dinitp,h,cpatch) + + !--------------------------------------------------------------------! + ! Integrate the implicit/backwards step ! + !--------------------------------------------------------------------! + call bdf2_solver(cpatch,yprev,initp,ytemp,dinitp,nsolve,h, & + dble(csite%hprev(ipa))) + + + !----- Perform a sanity check on canopy,leaf and wood stuff ---------! + call fb_sanity_check(ytemp,reject_step,csite,ipa,dinitp,h,print_diags) + + !---------------------------------------------------------------------------------! + ! Here we check the error of this step. Three outcomes are possible: ! + ! 1. The updated values make no sense. Reject step, assign a large error and ! + ! try again with a smaller time step; ! + ! 2. The updated values are reasonable, but the error is large. Reject step and ! + ! try again with a smaller time step; ! + ! 3. The updated values are reasonable, and the error is small. Accept step and ! + ! try again with a larger time step. ! + !---------------------------------------------------------------------------------! + if (reject_step) then + !------------------------------------------------------------------------------! + ! If step was already rejected, that means the step had finished premature- ! + ! ly, so we assign a standard large error (10.0). ! + !------------------------------------------------------------------------------! + errmax = 1.d1 + else + + errmax = 1.d-1 + + end if + + !---------------------------------------------------------------------------------! + ! 3. If the step failed, then calculate a new shorter step size to try. ! + !---------------------------------------------------------------------------------! + + if (reject_step) then + + !----- Defining new step and checking if it can be. ---------------------------! + oldh = h + newh = safety * h * errmax**pshrnk + minstep = (newh == h) .or. newh < hmin + + !----- Defining next time, and checking if it really added something. ---------! + h = max(1.d-1*h, newh) + xnew = x + h + stuck = xnew == x + + !------------------------------------------------------------------------------! + ! 3a. Here is the moment of truth... If we reached a tiny step and yet the ! + ! model didn't converge, then we print various values to inform the user ! + ! and abort the run. Please, don't hate the messenger. ! + !------------------------------------------------------------------------------! + + if (minstep .or. stuck ) then + + write (unit=*,fmt='(80a)') ('=',k=1,80) + write (unit=*,fmt='(a)') ' STEPSIZE UNDERFLOW IN EULER_INT' + write (unit=*,fmt='(80a)') ('-',k=1,80) + write (unit=*,fmt='(a,1x,f11.6)') ' + LONGITUDE: ',rk4site%lon + write (unit=*,fmt='(a,1x,f11.6)') ' + LATITUDE: ',rk4site%lat + write (unit=*,fmt='(a)') ' + PATCH INFO: ' + write (unit=*,fmt='(a,1x,i6)') ' - NUMBER: ',ipa + write (unit=*,fmt='(a,1x,es12.4)') ' - AGE: ',csite%age(ipa) + write (unit=*,fmt='(a,1x,i6)') ' - DIST_TYPE: ',csite%dist_type(ipa) + write (unit=*,fmt='(a,1x,l1)') ' + MINSTEP: ',minstep + write (unit=*,fmt='(a,1x,l1)') ' + STUCK: ',stuck + write (unit=*,fmt='(a,1x,es12.4)') ' + ERRMAX: ',errmax + write (unit=*,fmt='(a,1x,es12.4)') ' + X: ',x + write (unit=*,fmt='(a,1x,es12.4)') ' + H: ',h + write (unit=*,fmt='(a,1x,es12.4)') ' + OLDH: ',oldh + write (unit=*,fmt='(a,1x,es12.4)') ' + NEWH: ',newh + write (unit=*,fmt='(a,1x,es12.4)') ' + SAFETY: ',safety + write (unit=*,fmt='(80a)') ('-',k=1,80) + write (unit=*,fmt='(a)') ' Likely to be a rejected step problem.' + write (unit=*,fmt='(80a)') ('=',k=1,80) + + call fb_sanity_check(ytemp,test_reject,csite,ipa,dinitp,h,.true.) + call print_sanity_check(ytemp,csite,ipa) + call print_rk4patch(ytemp, csite,ipa) + end if + + else + !------------------------------------------------------------------------------! + ! 3b. Great, it worked, so now we can advance to the next step. We just need ! + ! to do some minor adjustments before... ! + !------------------------------------------------------------------------------! + + call adjust_veg_properties(ytemp,h,csite,ipa) + + !----- ii. Final update of top soil properties to avoid off-bounds moisture. -! + call adjust_topsoil_properties(ytemp,h,csite,ipa) + + !----- ii. Make temporary surface water stable and positively defined. --------! + call adjust_sfcw_properties(nzg,nzs,ytemp,h,csite,ipa) + + !----- iii. Update the diagnostic variables. ---------------------------------! + call update_diagnostic_vars(ytemp, csite,ipa) + !------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------! + ! 3c. Set up h for the next time. And here we can relax h for the next step, ! + ! and try something faster. ! + !------------------------------------------------------------------------------! + if (errmax > errcon) then + + hnext = min( (1.0+sqrt(2.0))*h,safety*h*errmax**pgrow)!,60.d0) + + else + + hnext = min( (1.d0+sqrt(2.d0))*h,5.d0*h)!,60.d0) + + endif + + hnext = max(2.d0*hmin,hnext) + + !------ 3d. Normalise the fluxes if the user wants detailed debugging. --------! + if (print_detailed) then + call norm_rk4_fluxes(ytemp,h) + call print_rk4_state(initp,ytemp,csite,ipa,x,h) + end if + + !----- 3e. Copy the temporary structure to the intermediate state. ------------! + call copy_initp2prev(initp,yprev,csite%patch(ipa)) + call copy_rk4_patch(ytemp, initp,csite%patch(ipa)) + + !------------------------------------------------------------------------------! + ! 3f. Flush step-by-step fluxes to zero if the user wants detailed ! + ! debugging. ! + !------------------------------------------------------------------------------! + if (print_detailed) then + call reset_rk4_fluxes(initp) + end if + + !----- 3g. Update time. -------------------------------------------------------! + csite%hprev(ipa) = sngl(h) + x = x + h + h = hnext + elaptime = elaptime + h + + exit hstep + end if + end do hstep + + !----- If the integration reached the next step, make some final adjustments --------! + if((x-tend)*dtrk4 >= 0.d0)then + + ksn = initp%nlev_sfcwater + + !---------------------------------------------------------------------------------! + ! Make temporary surface liquid water disappear. This will not happen ! + ! immediately, but liquid water will decay with the time scale defined by ! + ! runoff_time scale. If the time scale is too tiny, then it will be forced to be ! + ! hdid (no reason to be faster than that). ! + !---------------------------------------------------------------------------------! + if (simplerunoff .and. ksn >= 1) then + + if (initp%sfcwater_mass(ksn) > 0.d0 .and. & + initp%sfcwater_fracliq(ksn) > 1.d-1 ) then + + wfreeb = min(1.d0,dtrk4*runoff_time_i) * initp%sfcwater_mass(ksn) & + * (initp%sfcwater_fracliq(ksn) - 1.d-1) / 9.d-1 + + qwfree = wfreeb * cliq8 * (initp%sfcwater_tempk(ksn) - tsupercool_liq8 ) + + initp%sfcwater_mass(ksn) = initp%sfcwater_mass(ksn) - wfreeb + + initp%sfcwater_depth(ksn) = initp%sfcwater_depth(ksn) - wfreeb * wdnsi8 + + !----- Recompute the energy removing runoff --------------------------------! + initp%sfcwater_energy(ksn) = initp%sfcwater_energy(ksn) - qwfree + + call adjust_sfcw_properties(nzg,nzs,initp,dtrk4,csite,ipa) + call update_diagnostic_vars(initp,csite,ipa) + + !----- Compute runoff for output -------------------------------------------! + if (fast_diagnostics) then + csite%runoff(ipa) = csite%runoff(ipa) & + + sngloff(wfreeb * dtrk4i,tiny_offset) + csite%avg_runoff(ipa) = csite%avg_runoff(ipa) & + + sngloff(wfreeb * dtrk4i,tiny_offset) + csite%avg_runoff_heat(ipa) = csite%avg_runoff_heat(ipa) & + + sngloff(qwfree * dtrk4i,tiny_offset) + end if + if (checkbudget) then + initp%wbudget_loss2runoff = initp%wbudget_loss2runoff + wfreeb + initp%ebudget_loss2runoff = initp%ebudget_loss2runoff + qwfree + initp%wbudget_storage = initp%wbudget_storage - wfreeb + initp%ebudget_storage = initp%ebudget_storage - qwfree + end if + end if + end if + + !------ Update the substep for next time and leave -------------------------------! + + csite%htry(ipa) = sngl(hnext) + + call copy_prev2patch(yprev,csite,ipa) + + !---------------------------------------------------------------------------------! + ! Update the average time step. The square of DTLSM (tend-tbeg) is needed ! + ! because we will divide this by the time between t0 and t0+frqsum. ! + !---------------------------------------------------------------------------------! + csite%avg_rk4step(ipa) = csite%avg_rk4step(ipa) & + + sngl((tend-tbeg)*(tend-tbeg))/real(i) + nsteps = i + return + end if + + !----- Use hnext as the next substep ------------------------------------------------! + h = hnext + end do timesteploop + + !----- If it reached this point, that is really bad news... ----------------------------! + write (unit=*,fmt='(a)') ' ==> Too many steps in routine euler_integ' + call print_rk4patch(ytemp, csite,ipa) + + return + end subroutine hybrid_integ + + + !=========================================================================================! + !=========================================================================================! + + + subroutine copy_fb_patch(sourcep, targetp, cpatch,nsolve) + + use rk4_coms , only : rk4site & ! intent(in) + , rk4patchtype & ! structure + , checkbudget & ! intent(in) + , print_detailed ! ! intent(in) + use ed_state_vars , only : sitetype & ! structure + , patchtype ! ! structure + use grid_coms , only : nzg & ! intent(in) + , nzs ! ! intent(in) + use ed_max_dims , only : n_pft ! ! intent(in) + use ed_misc_coms , only : fast_diagnostics ! ! intent(in) + + implicit none + !----- Arguments -----------------------------------------------------------------------! + type(rk4patchtype) , target :: sourcep + type(rk4patchtype) , target :: targetp + type(patchtype) , target :: cpatch + integer :: nsolve + !----- Local variable ------------------------------------------------------------------! + integer :: k + !---------------------------------------------------------------------------------------! + + targetp%can_enthalpy = sourcep%can_enthalpy + targetp%can_theta = sourcep%can_theta + targetp%can_temp = sourcep%can_temp + targetp%can_shv = sourcep%can_shv + targetp%can_co2 = sourcep%can_co2 + targetp%can_rhos = sourcep%can_rhos + targetp%can_prss = sourcep%can_prss + targetp%can_exner = sourcep%can_exner + targetp%can_cp = sourcep%can_cp + targetp%can_depth = sourcep%can_depth + targetp%can_rhv = sourcep%can_rhv + targetp%can_ssh = sourcep%can_ssh + targetp%veg_height = sourcep%veg_height + targetp%veg_displace = sourcep%veg_displace + targetp%veg_rough = sourcep%veg_rough + targetp%opencan_frac = sourcep%opencan_frac + targetp%total_sfcw_depth = sourcep%total_sfcw_depth + targetp%snowfac = sourcep%snowfac + + targetp%ggbare = sourcep%ggbare + targetp%ggveg = sourcep%ggveg + targetp%ggnet = sourcep%ggnet + targetp%ggsoil = sourcep%ggsoil + + targetp%flag_wflxgc = sourcep%flag_wflxgc + + targetp%virtual_water = sourcep%virtual_water + targetp%virtual_energy = sourcep%virtual_energy + targetp%virtual_depth = sourcep%virtual_depth + targetp%virtual_tempk = sourcep%virtual_tempk + targetp%virtual_fracliq = sourcep%virtual_fracliq + + targetp%rough = sourcep%rough + + targetp%upwp = sourcep%upwp + targetp%wpwp = sourcep%wpwp + targetp%tpwp = sourcep%tpwp + targetp%qpwp = sourcep%qpwp + targetp%cpwp = sourcep%cpwp + + targetp%ground_shv = sourcep%ground_shv + targetp%ground_ssh = sourcep%ground_ssh + targetp%ground_temp = sourcep%ground_temp + targetp%ground_fliq = sourcep%ground_fliq + + targetp%ustar = sourcep%ustar + targetp%cstar = sourcep%cstar + targetp%tstar = sourcep%tstar + targetp%estar = sourcep%estar + targetp%qstar = sourcep%qstar + targetp%zeta = sourcep%zeta + targetp%ribulk = sourcep%ribulk + targetp%rasveg = sourcep%rasveg + + targetp%cwd_rh = sourcep%cwd_rh + targetp%rh = sourcep%rh + + do k=rk4site%lsl,nzg + targetp%soil_water (k) = sourcep%soil_water (k) + targetp%soil_energy (k) = sourcep%soil_energy (k) + targetp%soil_tempk (k) = sourcep%soil_tempk (k) + targetp%soil_fracliq (k) = sourcep%soil_fracliq (k) + end do + + targetp%nlev_sfcwater = sourcep%nlev_sfcwater + targetp%flag_sfcwater = sourcep%flag_sfcwater + + do k=1,nzs + targetp%sfcwater_mass (k) = sourcep%sfcwater_mass (k) + targetp%sfcwater_energy (k) = sourcep%sfcwater_energy (k) + targetp%sfcwater_depth (k) = sourcep%sfcwater_depth (k) + targetp%sfcwater_tempk (k) = sourcep%sfcwater_tempk (k) + targetp%sfcwater_fracliq(k) = sourcep%sfcwater_fracliq(k) + end do + + nsolve=1 + + do k=1,cpatch%ncohorts + targetp%leaf_resolvable (k) = sourcep%leaf_resolvable (k) + + if(targetp%leaf_resolvable(k)) nsolve=nsolve+1 + + targetp%leaf_energy (k) = sourcep%leaf_energy (k) + targetp%leaf_water (k) = sourcep%leaf_water (k) + targetp%leaf_temp (k) = sourcep%leaf_temp (k) + targetp%leaf_fliq (k) = sourcep%leaf_fliq (k) + targetp%leaf_hcap (k) = sourcep%leaf_hcap (k) + targetp%leaf_reynolds (k) = sourcep%leaf_reynolds (k) + targetp%leaf_grashof (k) = sourcep%leaf_grashof (k) + targetp%leaf_nussfree (k) = sourcep%leaf_nussfree (k) + targetp%leaf_nussforc (k) = sourcep%leaf_nussforc (k) + targetp%leaf_gbh (k) = sourcep%leaf_gbh (k) + targetp%leaf_gbw (k) = sourcep%leaf_gbw (k) + targetp%rshort_l (k) = sourcep%rshort_l (k) + targetp%rlong_l (k) = sourcep%rlong_l (k) + + targetp%wood_resolvable (k) = sourcep%wood_resolvable (k) + + if(targetp%wood_resolvable(k)) nsolve=nsolve+1 + + targetp%wood_energy (k) = sourcep%wood_energy (k) + targetp%wood_water (k) = sourcep%wood_water (k) + targetp%wood_temp (k) = sourcep%wood_temp (k) + targetp%wood_fliq (k) = sourcep%wood_fliq (k) + targetp%wood_hcap (k) = sourcep%wood_hcap (k) + targetp%wood_reynolds (k) = sourcep%wood_reynolds (k) + targetp%wood_grashof (k) = sourcep%wood_grashof (k) + targetp%wood_nussfree (k) = sourcep%wood_nussfree (k) + targetp%wood_nussforc (k) = sourcep%wood_nussforc (k) + targetp%wood_gbh (k) = sourcep%wood_gbh (k) + targetp%wood_gbw (k) = sourcep%wood_gbw (k) + targetp%rshort_w (k) = sourcep%rshort_w (k) + targetp%rlong_w (k) = sourcep%rlong_w (k) + + targetp%veg_resolvable (k) = sourcep%veg_resolvable (k) + targetp%veg_energy (k) = sourcep%veg_energy (k) + targetp%veg_water (k) = sourcep%veg_water (k) + targetp%veg_hcap (k) = sourcep%veg_hcap (k) + + targetp%veg_wind (k) = sourcep%veg_wind (k) + targetp%lint_shv (k) = sourcep%lint_shv (k) + targetp%nplant (k) = sourcep%nplant (k) + targetp%lai (k) = sourcep%lai (k) + targetp%wai (k) = sourcep%wai (k) + targetp%tai (k) = sourcep%tai (k) + targetp%crown_area (k) = sourcep%crown_area (k) + targetp%elongf (k) = sourcep%elongf (k) + targetp%gsw_open (k) = sourcep%gsw_open (k) + targetp%gsw_closed (k) = sourcep%gsw_closed (k) + targetp%psi_open (k) = sourcep%psi_open (k) + targetp%psi_closed (k) = sourcep%psi_closed (k) + targetp%fs_open (k) = sourcep%fs_open (k) + targetp%gpp (k) = sourcep%gpp (k) + targetp%leaf_resp (k) = sourcep%leaf_resp (k) + targetp%root_resp (k) = sourcep%root_resp (k) + targetp%growth_resp (k) = sourcep%growth_resp (k) + targetp%storage_resp (k) = sourcep%storage_resp (k) + targetp%vleaf_resp (k) = sourcep%vleaf_resp (k) + end do + + if (checkbudget) then + targetp%co2budget_storage = sourcep%co2budget_storage + targetp%co2budget_loss2atm = sourcep%co2budget_loss2atm + targetp%ebudget_netrad = sourcep%ebudget_netrad + targetp%ebudget_loss2atm = sourcep%ebudget_loss2atm + targetp%ebudget_loss2drainage = sourcep%ebudget_loss2drainage + targetp%ebudget_loss2runoff = sourcep%ebudget_loss2runoff + targetp%wbudget_loss2atm = sourcep%wbudget_loss2atm + targetp%wbudget_loss2drainage = sourcep%wbudget_loss2drainage + targetp%wbudget_loss2runoff = sourcep%wbudget_loss2runoff + targetp%ebudget_storage = sourcep%ebudget_storage + targetp%wbudget_storage = sourcep%wbudget_storage + end if + if (fast_diagnostics) then + targetp%avg_ustar = sourcep%avg_ustar + targetp%avg_tstar = sourcep%avg_tstar + targetp%avg_qstar = sourcep%avg_qstar + targetp%avg_cstar = sourcep%avg_cstar + targetp%avg_carbon_ac = sourcep%avg_carbon_ac + targetp%avg_carbon_st = sourcep%avg_carbon_st + targetp%avg_vapor_lc = sourcep%avg_vapor_lc + targetp%avg_vapor_wc = sourcep%avg_vapor_wc + targetp%avg_vapor_gc = sourcep%avg_vapor_gc + targetp%avg_wshed_vg = sourcep%avg_wshed_vg + targetp%avg_intercepted = sourcep%avg_intercepted + targetp%avg_throughfall = sourcep%avg_throughfall + targetp%avg_vapor_ac = sourcep%avg_vapor_ac + targetp%avg_transp = sourcep%avg_transp + targetp%avg_evap = sourcep%avg_evap + targetp%avg_rshort_gnd = sourcep%avg_rshort_gnd + targetp%avg_rlong_gnd = sourcep%avg_rlong_gnd + targetp%avg_sensible_lc = sourcep%avg_sensible_lc + targetp%avg_sensible_wc = sourcep%avg_sensible_wc + targetp%avg_qwshed_vg = sourcep%avg_qwshed_vg + targetp%avg_qintercepted = sourcep%avg_qintercepted + targetp%avg_qthroughfall = sourcep%avg_qthroughfall + targetp%avg_sensible_gc = sourcep%avg_sensible_gc + targetp%avg_sensible_ac = sourcep%avg_sensible_ac + targetp%avg_drainage = sourcep%avg_drainage + targetp%avg_drainage_heat = sourcep%avg_drainage_heat + + do k=rk4site%lsl,nzg + targetp%avg_sensible_gg(k) = sourcep%avg_sensible_gg(k) + targetp%avg_smoist_gg(k) = sourcep%avg_smoist_gg(k) + targetp%avg_transloss(k) = sourcep%avg_transloss(k) + end do + end if + + if (print_detailed) then + targetp%flx_carbon_ac = sourcep%flx_carbon_ac + targetp%flx_carbon_st = sourcep%flx_carbon_st + targetp%flx_vapor_lc = sourcep%flx_vapor_lc + targetp%flx_vapor_wc = sourcep%flx_vapor_wc + targetp%flx_vapor_gc = sourcep%flx_vapor_gc + targetp%flx_wshed_vg = sourcep%flx_wshed_vg + targetp%flx_intercepted = sourcep%flx_intercepted + targetp%flx_throughfall = sourcep%flx_throughfall + targetp%flx_vapor_ac = sourcep%flx_vapor_ac + targetp%flx_transp = sourcep%flx_transp + targetp%flx_evap = sourcep%flx_evap + targetp%flx_rshort_gnd = sourcep%flx_rshort_gnd + targetp%flx_rlong_gnd = sourcep%flx_rlong_gnd + targetp%flx_sensible_lc = sourcep%flx_sensible_lc + targetp%flx_sensible_wc = sourcep%flx_sensible_wc + targetp%flx_qwshed_vg = sourcep%flx_qwshed_vg + targetp%flx_qintercepted = sourcep%flx_qintercepted + targetp%flx_qthroughfall = sourcep%flx_qthroughfall + targetp%flx_sensible_gc = sourcep%flx_sensible_gc + targetp%flx_sensible_ac = sourcep%flx_sensible_ac + targetp%flx_drainage = sourcep%flx_drainage + targetp%flx_drainage_heat = sourcep%flx_drainage_heat + + do k=rk4site%lsl,nzg + targetp%flx_sensible_gg(k) = sourcep%flx_sensible_gg(k) + targetp%flx_smoist_gg(k) = sourcep%flx_smoist_gg(k) + targetp%flx_transloss(k) = sourcep%flx_transloss(k) + end do + + do k=1,cpatch%ncohorts + targetp%cfx_hflxlc (k) = sourcep%cfx_hflxlc (k) + targetp%cfx_hflxwc (k) = sourcep%cfx_hflxwc (k) + targetp%cfx_qwflxlc (k) = sourcep%cfx_qwflxlc (k) + targetp%cfx_qwflxwc (k) = sourcep%cfx_qwflxwc (k) + targetp%cfx_qwshed (k) = sourcep%cfx_qwshed (k) + targetp%cfx_qtransp (k) = sourcep%cfx_qtransp (k) + targetp%cfx_qintercepted(k) = sourcep%cfx_qintercepted(k) + end do + end if + + end subroutine copy_fb_patch + + + !=============================================================! + + subroutine copy_initp2prev(initp,yprev,cpatch) + + use rk4_coms , only : rk4patchtype,bdf2patchtype + use ed_state_vars , only : patchtype + + implicit none + + type(rk4patchtype), target :: initp ! Main memory + type(bdf2patchtype), target :: yprev ! Buffer memory + type(patchtype),target :: cpatch + integer :: ico + + yprev%can_temp = initp%can_temp + + do ico=1,cpatch%ncohorts + yprev%leaf_temp(ico) = initp%leaf_temp(ico) + yprev%wood_temp(ico) = initp%wood_temp(ico) + end do + + return + end subroutine copy_initp2prev + + subroutine copy_prev2patch(yprev,csite,ipa) + + use rk4_coms , only : bdf2patchtype + use ed_state_vars , only : patchtype,sitetype + + implicit none + + type(bdf2patchtype), target :: yprev ! Buffer memory + type(patchtype),pointer :: cpatch + type(sitetype),target :: csite + integer :: ico,ipa + + cpatch => csite%patch(ipa) + csite%can_temp_pv(ipa) = yprev%can_temp + + do ico=1,cpatch%ncohorts + cpatch%leaf_temp_pv(ico) = yprev%leaf_temp(ico) + cpatch%wood_temp_pv(ico) = yprev%wood_temp(ico) + end do + + return + end subroutine copy_prev2patch + + + + !=============================================================! + + subroutine copy_bdf2_prev(csite,ipa,yprev) + + use ed_state_vars , only : patchtype,sitetype ! ! structure + use rk4_coms , only : bdf2patchtype ! structure + + implicit none + + type(sitetype) , target :: csite + type(patchtype) , pointer :: cpatch ! Main memory + type(bdf2patchtype), target :: yprev ! Buffer memory + integer :: ipa + integer :: ico + + cpatch => csite%patch(ipa) + yprev%can_temp = csite%can_temp_pv(ipa) + + do ico=1,cpatch%ncohorts + yprev%leaf_temp(ico) = cpatch%leaf_temp_pv(ico) + yprev%wood_temp(ico) = cpatch%wood_temp_pv(ico) + end do + + return + end subroutine copy_bdf2_prev + +!=============================================================! + + + subroutine inc_fwd_patch(rkp, inc, fac, cpatch) + use ed_state_vars , only : sitetype & ! structure + , patchtype ! ! structure + use rk4_coms , only : rk4patchtype & ! structure + , rk4site & ! intent(in) + , checkbudget & ! intent(in) + , print_detailed ! ! intent(in) + use grid_coms , only : nzg & ! intent(in) + , nzs ! ! intent(in) + use ed_misc_coms , only : fast_diagnostics ! ! intent(in) + + implicit none + + !----- Arguments -----------------------------------------------------------------------! + type(rk4patchtype) , target :: rkp ! Temporary patch with previous state + type(rk4patchtype) , target :: inc ! Temporary patch with its derivatives + type(patchtype) , target :: cpatch ! Current patch (for characteristics) + real(kind=8) , intent(in) :: fac ! Increment factor + !----- Local variables -----------------------------------------------------------------! + integer :: ico ! Cohort ID + integer :: k ! Counter + !---------------------------------------------------------------------------------------! + + + + + rkp%can_enthalpy = rkp%can_enthalpy + fac * inc%can_enthalpy + rkp%can_shv = rkp%can_shv + fac * inc%can_shv + rkp%can_co2 = rkp%can_co2 + fac * inc%can_co2 + + do k=rk4site%lsl,nzg + rkp%soil_water(k) = rkp%soil_water(k) + fac * inc%soil_water(k) + rkp%soil_energy(k) = rkp%soil_energy(k) + fac * inc%soil_energy(k) + end do + + do k=1,rkp%nlev_sfcwater + rkp%sfcwater_mass(k) = rkp%sfcwater_mass(k) + fac * inc%sfcwater_mass(k) + rkp%sfcwater_energy(k) = rkp%sfcwater_energy(k) + fac * inc%sfcwater_energy(k) + rkp%sfcwater_depth(k) = rkp%sfcwater_depth(k) + fac * inc%sfcwater_depth(k) + end do + + rkp%virtual_energy = rkp%virtual_energy + fac * inc%virtual_energy + rkp%virtual_water = rkp%virtual_water + fac * inc%virtual_water + rkp%virtual_depth = rkp%virtual_depth + fac * inc%virtual_depth + + + rkp%upwp = rkp%upwp + fac * inc%upwp + rkp%wpwp = rkp%wpwp + fac * inc%wpwp + rkp%tpwp = rkp%tpwp + fac * inc%tpwp + rkp%qpwp = rkp%qpwp + fac * inc%qpwp + rkp%cpwp = rkp%cpwp + fac * inc%cpwp + + do ico = 1,cpatch%ncohorts + rkp%leaf_water (ico) = rkp%leaf_water (ico) + fac * inc%leaf_water (ico) + rkp%leaf_energy(ico) = rkp%leaf_energy(ico) + fac * inc%leaf_energy(ico) + rkp%wood_water (ico) = rkp%wood_water (ico) + fac * inc%wood_water (ico) + rkp%wood_energy(ico) = rkp%wood_energy(ico) + fac * inc%wood_energy(ico) + rkp%veg_water (ico) = rkp%veg_water (ico) + fac * inc%veg_water (ico) + rkp%veg_energy(ico) = rkp%veg_energy (ico) + fac * inc%veg_energy (ico) + + rkp%psi_open (ico) = rkp%psi_open (ico) + fac * inc%psi_open (ico) + rkp%psi_closed(ico) = rkp%psi_closed(ico) + fac * inc%psi_closed(ico) + end do + + if (checkbudget) then + + rkp%co2budget_storage = rkp%co2budget_storage + fac * inc%co2budget_storage + rkp%co2budget_loss2atm = rkp%co2budget_loss2atm + fac * inc%co2budget_loss2atm + + rkp%wbudget_storage = rkp%wbudget_storage + fac * inc%wbudget_storage + rkp%wbudget_loss2atm = rkp%wbudget_loss2atm + fac * inc%wbudget_loss2atm + rkp%wbudget_loss2drainage = rkp%wbudget_loss2drainage & + + fac * inc%wbudget_loss2drainage + + rkp%ebudget_storage = rkp%ebudget_storage + fac * inc%ebudget_storage + rkp%ebudget_netrad = rkp%ebudget_netrad + fac * inc%ebudget_netrad + rkp%ebudget_loss2atm = rkp%ebudget_loss2atm + fac * inc%ebudget_loss2atm + rkp%ebudget_loss2drainage = rkp%ebudget_loss2drainage & + + fac * inc%ebudget_loss2drainage + end if + if (fast_diagnostics) then + rkp%avg_ustar = rkp%avg_ustar + fac * inc%avg_ustar + rkp%avg_tstar = rkp%avg_tstar + fac * inc%avg_tstar + rkp%avg_qstar = rkp%avg_qstar + fac * inc%avg_qstar + rkp%avg_cstar = rkp%avg_cstar + fac * inc%avg_cstar + + + rkp%avg_carbon_ac = rkp%avg_carbon_ac + fac * inc%avg_carbon_ac + rkp%avg_carbon_st = rkp%avg_carbon_st + fac * inc%avg_carbon_st + + rkp%avg_vapor_lc = rkp%avg_vapor_lc + fac * inc%avg_vapor_lc + rkp%avg_vapor_wc = rkp%avg_vapor_wc + fac * inc%avg_vapor_wc + rkp%avg_vapor_gc = rkp%avg_vapor_gc + fac * inc%avg_vapor_gc + rkp%avg_wshed_vg = rkp%avg_wshed_vg + fac * inc%avg_wshed_vg + rkp%avg_intercepted = rkp%avg_intercepted + fac * inc%avg_intercepted + rkp%avg_throughfall = rkp%avg_throughfall + fac * inc%avg_throughfall + rkp%avg_vapor_ac = rkp%avg_vapor_ac + fac * inc%avg_vapor_ac + rkp%avg_transp = rkp%avg_transp + fac * inc%avg_transp + rkp%avg_evap = rkp%avg_evap + fac * inc%avg_evap + rkp%avg_drainage = rkp%avg_drainage + fac * inc%avg_drainage + rkp%avg_drainage_heat = rkp%avg_drainage_heat + fac * inc%avg_drainage_heat + rkp%avg_rshort_gnd = rkp%avg_rshort_gnd + fac * inc%avg_rshort_gnd + rkp%avg_rlong_gnd = rkp%avg_rlong_gnd + fac * inc%avg_rlong_gnd + rkp%avg_sensible_lc = rkp%avg_sensible_lc + fac * inc%avg_sensible_lc + rkp%avg_sensible_wc = rkp%avg_sensible_wc + fac * inc%avg_sensible_wc + rkp%avg_qwshed_vg = rkp%avg_qwshed_vg + fac * inc%avg_qwshed_vg + rkp%avg_qintercepted = rkp%avg_qintercepted + fac * inc%avg_qintercepted + rkp%avg_qthroughfall = rkp%avg_qthroughfall + fac * inc%avg_qthroughfall + rkp%avg_sensible_gc = rkp%avg_sensible_gc + fac * inc%avg_sensible_gc + rkp%avg_sensible_ac = rkp%avg_sensible_ac + fac * inc%avg_sensible_ac + + do k=rk4site%lsl,nzg + rkp%avg_sensible_gg(k) = rkp%avg_sensible_gg(k) + fac * inc%avg_sensible_gg(k) + rkp%avg_smoist_gg(k) = rkp%avg_smoist_gg(k) + fac * inc%avg_smoist_gg(k) + rkp%avg_transloss(k) = rkp%avg_transloss(k) + fac * inc%avg_transloss(k) + end do + + end if + + !---------------------------------------------------------------------------------------! + ! Increment the instantaneous fluxes. The derivative term should be the same as the ! + ! the full fluxes, the only difference is that these variables are normalised and ! + ! re-set after each time step. ! + !---------------------------------------------------------------------------------------! + if (print_detailed) then + rkp%flx_carbon_ac = rkp%flx_carbon_ac + fac * inc%avg_carbon_ac + rkp%flx_carbon_st = rkp%flx_carbon_st + fac * inc%avg_carbon_st + + rkp%flx_vapor_lc = rkp%flx_vapor_lc + fac * inc%avg_vapor_lc + rkp%flx_vapor_wc = rkp%flx_vapor_wc + fac * inc%avg_vapor_wc + rkp%flx_vapor_gc = rkp%flx_vapor_gc + fac * inc%avg_vapor_gc + rkp%flx_wshed_vg = rkp%flx_wshed_vg + fac * inc%avg_wshed_vg + rkp%flx_intercepted = rkp%flx_intercepted + fac * inc%avg_intercepted + rkp%flx_throughfall = rkp%flx_throughfall + fac * inc%avg_throughfall + rkp%flx_vapor_ac = rkp%flx_vapor_ac + fac * inc%avg_vapor_ac + rkp%flx_transp = rkp%flx_transp + fac * inc%avg_transp + rkp%flx_evap = rkp%flx_evap + fac * inc%avg_evap + rkp%flx_drainage = rkp%flx_drainage + fac * inc%avg_drainage + rkp%flx_drainage_heat = rkp%flx_drainage_heat + fac * inc%avg_drainage_heat + rkp%flx_rshort_gnd = rkp%flx_rshort_gnd + fac * inc%avg_rshort_gnd + rkp%flx_rlong_gnd = rkp%flx_rlong_gnd + fac * inc%avg_rlong_gnd + rkp%flx_sensible_lc = rkp%flx_sensible_lc + fac * inc%avg_sensible_lc + rkp%flx_sensible_wc = rkp%flx_sensible_wc + fac * inc%avg_sensible_wc + rkp%flx_qwshed_vg = rkp%flx_qwshed_vg + fac * inc%avg_qwshed_vg + rkp%flx_qintercepted = rkp%flx_qintercepted + fac * inc%avg_qintercepted + rkp%flx_qthroughfall = rkp%flx_qthroughfall + fac * inc%avg_qthroughfall + rkp%flx_sensible_gc = rkp%flx_sensible_gc + fac * inc%avg_sensible_gc + rkp%flx_sensible_ac = rkp%flx_sensible_ac + fac * inc%avg_sensible_ac + + do k=rk4site%lsl,nzg + rkp%flx_sensible_gg(k) = rkp%flx_sensible_gg(k) + fac * inc%avg_sensible_gg(k) + rkp%flx_smoist_gg(k) = rkp%flx_smoist_gg(k) + fac * inc%avg_smoist_gg(k) + rkp%flx_transloss(k) = rkp%flx_transloss(k) + fac * inc%avg_transloss(k) + end do + + do ico = 1,cpatch%ncohorts + rkp%cfx_hflxlc (ico) = rkp%cfx_hflxlc (ico) & + + fac * inc%cfx_hflxlc (ico) + rkp%cfx_hflxwc (ico) = rkp%cfx_hflxwc (ico) & + + fac * inc%cfx_hflxwc (ico) + rkp%cfx_qwflxlc (ico) = rkp%cfx_qwflxlc (ico) & + + fac * inc%cfx_qwflxlc (ico) + rkp%cfx_qwflxwc (ico) = rkp%cfx_qwflxwc (ico) & + + fac * inc%cfx_qwflxwc (ico) + rkp%cfx_qwshed (ico) = rkp%cfx_qwshed (ico) & + + fac * inc%cfx_qwshed (ico) + rkp%cfx_qtransp (ico) = rkp%cfx_qtransp (ico) & + + fac * inc%cfx_qtransp (ico) + rkp%cfx_qintercepted(ico) = rkp%cfx_qintercepted(ico) & + + fac * inc%cfx_qintercepted(ico) + end do + + end if + + !---------------------------------------------------------------------------------------! + + return + end subroutine inc_fwd_patch + + ! ========================================================================= ! + + subroutine fb_dy_step_trunc(y,restart_step,csite,ipa,dydx,h,hmin) + + use rk4_coms , only : rk4patchtype & ! structure + , integration_vars & ! structure + , rk4site & ! intent(in) + , rk4eps & ! intent(in) + , toocold & ! intent(in) + , rk4max_can_shv & ! intent(in) + , rk4min_can_shv & ! intent(in) + , rk4min_can_rhv & ! intent(in) + , rk4max_can_rhv & ! intent(in) + , rk4min_can_temp & ! intent(in) + , rk4max_can_temp & ! intent(in) + , rk4min_can_prss & ! intent(in) + , rk4max_can_prss & ! intent(in) + , rk4min_can_co2 & ! intent(in) + , rk4max_can_co2 & ! intent(in) + , rk4max_veg_temp & ! intent(in) + , rk4min_veg_temp & ! intent(in) + , rk4min_veg_lwater & ! intent(in) + , rk4min_sfcw_temp & ! intent(in) + , rk4max_sfcw_temp & ! intent(in) + , rk4max_soil_temp & ! intent(in) + , rk4min_soil_temp & ! intent(in) + , rk4max_soil_water & ! intent(in) + , rk4min_soil_water & ! intent(in) + , rk4min_sfcw_mass & ! intent(in) + , rk4min_virt_water & ! intent(in) + , rk4tiny_sfcw_mass & ! intent(in) + , rk4water_stab_thresh & ! intent(in) + , integ_err & ! intent(inout) + , record_err & ! intent(in) + , osow & ! intent(in) + , osoe & ! intent(in) + , oswe & ! intent(in) + , oswm ! ! intent(in) + use ed_state_vars , only : sitetype & ! structure + , patchtype ! ! structure + use grid_coms , only : nzg ! ! intent(in) + use therm_lib8 , only : eslif8 + use consts_coms , only : ep8 + use soil_coms , only : soil8 + + implicit none + !----- Arguments --------------------------------------------------------------------! + type(rk4patchtype) , target :: y + type(rk4patchtype) , target :: dydx + type(sitetype) , target :: csite + real(kind=8) , intent(in) :: h + real(kind=8) , intent(out) :: hmin + !----- Local variables --------------------------------------------------------------! + type(patchtype) , pointer :: cpatch + integer :: k + integer :: ksn + real(kind=8) :: rk4min_leaf_water + real(kind=8) :: rk4min_wood_water + real(kind=8) :: fbmax_can_shv + real(kind=8) :: max_dco2_can + real(kind=8) :: max_dshv_can + real(kind=8) :: max_dtheta_can + real(kind=8) :: max_dwater_soil + real(kind=8) :: max_denergy_soil + real(kind=8) :: hmin_tmp + integer :: ipa + integer :: ico + integer :: section ! either 1 or 2 or 3 + + logical :: cflag7 + logical :: cflag8 + logical :: cflag9 + logical :: cflag10 + logical :: restart_step + !------------------------------------------------------------------------------------! + + restart_step = .false. + + ! ---------------- Maximum step change in canopy CO2 (PPM) --------------------------! + +!! max_dco2_can = 20.d0 +!! hmin = max_dco2_can/abs(dydx%can_co2) + +!! if ( h > max_dco2_can/abs(dydx%can_co2) .and. record_err) & +!! integ_err(6,1) = integ_err(6,1) + 1_8 + + ! ---------------- Maximum change in canopy Relative Humidity ----------------------! + + max_dshv_can = 0.15d0 + hmin = (max_dshv_can*y%can_shv)/abs(dydx%can_shv) + + if ( h > max_dshv_can/abs(dydx%can_shv) .and. record_err) then + integ_err(3,1) = integ_err(3,1) + 1_8 + end if + + ! ---------------- Maximum change in the first soil layer --------------------------! + +!! max_dwater_soil = 0.5d0 ! Maximum change in relative soil moisture + +!! do k=rk4site%lsl,nzg + +!! hmin_tmp = max_dwater_soil/(abs(dydx%soil_water(k))/soil8(rk4site%ntext_soil(k))%slmsts) +!! hmin = min(hmin,hmin_tmp) + +!! if ( h > hmin_tmp .and. record_err) & +!! integ_err(osow+k,1) = integ_err(osow+k,1) + 1_8 + +!! end do + + if (hmin < 0.99999*h) then + restart_step = .true. + else + restart_step = .false. + end if + + return + end subroutine fb_dy_step_trunc + + !=========================================================== + + subroutine fb_sanity_check(y,reject_step, csite,ipa,dydx,h, & + print_problems) + use rk4_coms , only : rk4patchtype & ! structure + , integration_vars & ! structure + , rk4site & ! intent(in) + , rk4eps & ! intent(in) + , toocold & ! intent(in) + , rk4max_can_shv & ! intent(in) + , rk4min_can_shv & ! intent(in) + , rk4min_can_rhv & ! intent(in) + , rk4max_can_rhv & ! intent(in) + , rk4min_can_temp & ! intent(in) + , rk4max_can_temp & ! intent(in) + , rk4min_can_prss & ! intent(in) + , rk4max_can_prss & ! intent(in) + , rk4min_can_co2 & ! intent(in) + , rk4max_can_co2 & ! intent(in) + , rk4max_veg_temp & ! intent(in) + , rk4min_veg_temp & ! intent(in) + , rk4min_veg_lwater & ! intent(in) + , rk4min_sfcw_temp & ! intent(in) + , rk4max_sfcw_temp & ! intent(in) + , rk4max_soil_temp & ! intent(in) + , rk4min_soil_temp & ! intent(in) + , rk4max_soil_water & ! intent(in) + , rk4min_soil_water & ! intent(in) + , rk4min_sfcw_mass & ! intent(in) + , rk4min_virt_water & ! intent(in) + , rk4tiny_sfcw_mass & ! intent(in) + , rk4water_stab_thresh & ! intent(in) + , integ_err & ! intent(inout) + , record_err & ! intent(in) + , osow & ! intent(in) + , osoe & ! intent(in) + , oswe & ! intent(in) + , oswm ! ! intent(in) + use ed_state_vars , only : sitetype & ! structure + , patchtype ! ! structure + use grid_coms , only : nzg ! ! intent(in) + use therm_lib8 , only : eslif8 + use consts_coms , only : ep8 + + implicit none + !----- Arguments --------------------------------------------------------------------! + type(rk4patchtype) , target :: y + type(rk4patchtype) , target :: dydx + type(sitetype) , target :: csite + logical , intent(in) :: print_problems + logical , intent(out) :: reject_step + real(kind=8) , intent(in) :: h + !----- Local variables --------------------------------------------------------------! + type(patchtype) , pointer :: cpatch + integer :: k + integer :: ksn + real(kind=8) :: rk4min_leaf_water + real(kind=8) :: rk4min_wood_water + real(kind=8) :: fbmax_can_shv + real(kind=8) :: max_dco2 + real(kind=8) :: max_dshv + real(kind=8) :: max_dtheta + integer :: ipa + integer :: ico + integer :: section ! either 1 or 2 or 3 + + logical :: cflag7 + logical :: cflag8 + logical :: cflag9 + logical :: cflag10 + !------------------------------------------------------------------------------------! + + !----- Be optimistic and start assuming that things are fine. -----------------------! + reject_step = .false. + !------------------------------------------------------------------------------------! + + fbmax_can_shv = ep8*eslif8(320.d0)/y%can_prss + + + if ( y%can_shv > fbmax_can_shv .or. y%can_shv < rk4min_can_shv ) then + reject_step = .true. + if(record_err) integ_err(3,2) = integ_err(3,2) + 1_8 + if (print_problems) then + write(unit=*,fmt='(a)') '===========================================' + write(unit=*,fmt='(a)') ' + Canopy air sp. humidity is off-track...' + write(unit=*,fmt='(a)') '-------------------------------------------' + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THETA: ',y%can_theta + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_SHV: ',y%can_shv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHV: ',y%can_rhv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_TEMP: ',y%can_temp + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHOS: ',y%can_rhos + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_CO2: ',y%can_co2 + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_DEPTH: ',y%can_depth + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_PRSS: ',y%can_prss + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_TEMP )/Dt:',dydx%can_theta + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_SHV )/Dt:',dydx%can_shv + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_CO2 )/Dt:',dydx%can_co2 + write(unit=*,fmt='(a)') '===========================================' + write(unit=*,fmt='(a)') ' ' + elseif (.not. record_err) then + return + end if + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Check whether the canopy air temperature is off. ! + !------------------------------------------------------------------------------------! + if (y%can_temp > rk4max_can_temp .or. y%can_temp < rk4min_can_temp) then + reject_step = .true. + if(record_err) integ_err(4,2) = integ_err(4,2) + 1_8 + if (print_problems) then + write(unit=*,fmt='(a)') '===========================================' + write(unit=*,fmt='(a)') ' + Canopy air temperature is off-track...' + write(unit=*,fmt='(a)') '-------------------------------------------' + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THETA: ',y%can_theta + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_SHV: ',y%can_shv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHV: ',y%can_rhv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_TEMP: ',y%can_temp + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHOS: ',y%can_rhos + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_CO2: ',y%can_co2 + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_DEPTH: ',y%can_depth + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_PRSS: ',y%can_prss + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_TEMP )/Dt:',dydx%can_theta + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_SHV )/Dt:',dydx%can_shv + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_CO2 )/Dt:',dydx%can_co2 + write(unit=*,fmt='(a)') '===========================================' + write(unit=*,fmt='(a)') ' ' + elseif (.not. record_err) then + return + end if + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Check whether the canopy air pressure is off. ! + !------------------------------------------------------------------------------------! + if (y%can_prss > rk4max_can_prss .or. y%can_prss < rk4min_can_prss) then + reject_step = .true. + if(record_err) integ_err(5,2) = integ_err(5,2) + 1_8 + if (print_problems) then + write(unit=*,fmt='(a)') '===========================================' + write(unit=*,fmt='(a)') ' + Canopy air pressure is off-track...' + write(unit=*,fmt='(a)') '-------------------------------------------' + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THETA: ',y%can_theta + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_SHV: ',y%can_shv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHV: ',y%can_rhv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_TEMP: ',y%can_temp + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHOS: ',y%can_rhos + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_CO2: ',y%can_co2 + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_DEPTH: ',y%can_depth + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_PRSS: ',y%can_prss + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_TEMP )/Dt:',dydx%can_theta + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_SHV )/Dt:',dydx%can_shv + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_CO2 )/Dt:',dydx%can_co2 + write(unit=*,fmt='(a)') '===========================================' + write(unit=*,fmt='(a)') ' ' + elseif (.not. record_err) then + return + end if + end if + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Check whether the canopy air co2 is off. ! + !------------------------------------------------------------------------------------! + if (y%can_co2 > rk4max_can_co2 .or. y%can_co2 < rk4min_can_co2) then + reject_step = .true. + if(record_err) integ_err(6,2) = integ_err(6,2) + 1_8 + if (print_problems) then + write(unit=*,fmt='(a)') '===========================================' + write(unit=*,fmt='(a)') ' + Canopy air CO2 is off-track...' + write(unit=*,fmt='(a)') '-------------------------------------------' + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THETA: ',y%can_theta + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_SHV: ',y%can_shv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHV: ',y%can_rhv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_TEMP: ',y%can_temp + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHOS: ',y%can_rhos + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_CO2: ',y%can_co2 + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_DEPTH: ',y%can_depth + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_PRSS: ',y%can_prss + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_TEMP )/Dt:',dydx%can_theta + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_SHV )/Dt:',dydx%can_shv + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_CO2 )/Dt:',dydx%can_co2 + write(unit=*,fmt='(a)') '===========================================' + write(unit=*,fmt='(a)') ' ' + stop + elseif (.not. record_err) then + return + end if + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Check leaf properties, but only for those cohorts with sufficient LAI. ! + !------------------------------------------------------------------------------------! + cpatch => csite%patch(ipa) + cflag7 = .false. + cflag8 = .false. + leafloop: do ico = 1,cpatch%ncohorts + if (.not. y%leaf_resolvable(ico)) cycle leafloop + + !----- Find the minimum leaf surface water. --------------------------------------! + rk4min_leaf_water = rk4min_veg_lwater * y%lai(ico) + + !----- Check leaf surface water. -------------------------------------------------! + if (y%leaf_water(ico) < rk4min_leaf_water) then + reject_step = .true. + if(record_err) cflag7 = .true. + if (print_problems) then + write(unit=*,fmt='(a)') '========================================' + write(unit=*,fmt='(a)') ' + Leaf surface water is off-track...' + write(unit=*,fmt='(a)') '========================================' + write(unit=*,fmt='(a,1x,i6)') ' PFT: ',cpatch%pft(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' HEIGHT: ',cpatch%hite(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LAI: ',y%lai(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WAI: ',y%wai(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' TAI: ',y%tai(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' NPLANT: ',y%nplant(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' CROWN_AREA: ',y%crown_area(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_HCAP: ',y%leaf_hcap(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_TEMP: ',y%leaf_temp(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_FRACLIQ: ',y%leaf_fliq(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_ENERGY: ',y%leaf_energy(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_WATER: ',y%leaf_water(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' VEG_WIND: ',y%veg_wind(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LINT_SHV: ',y%lint_shv(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' MIN_LEAF_WATER:',rk4min_leaf_water + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_GBH: ',y%leaf_gbh(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_GBW: ',y%leaf_gbw(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_REYNOLDS: ',y%leaf_reynolds(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_GRASHOF: ',y%leaf_grashof(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_NUFREE: ',y%leaf_nussfree(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_NUFORC: ',y%leaf_nussforc(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' D(LEAF_EN)/Dt: ',dydx%leaf_energy(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' D(LEAF_WAT)/Dt:',dydx%leaf_water(ico) + write(unit=*,fmt='(a)') '========================================' + elseif (.not. record_err) then + return + end if + end if + + !----- Check leaf temperature. ---------------------------------------------------! + if (y%leaf_temp(ico) > rk4max_veg_temp .or. & + y%leaf_temp(ico) < rk4min_veg_temp ) then + reject_step = .true. + if(record_err) cflag8 = .true. + if (print_problems) then + write(unit=*,fmt='(a)') '========================================' + write(unit=*,fmt='(a)') ' + Leaf temperature is off-track...' + write(unit=*,fmt='(a)') '========================================' + write(unit=*,fmt='(a,1x,i6)') ' PFT: ',cpatch%pft(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' HEIGHT: ',cpatch%hite(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LAI: ',y%lai(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WAI: ',y%wai(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' TAI: ',y%tai(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' NPLANT: ',y%nplant(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' CROWN_AREA: ',y%crown_area(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_HCAP: ',y%leaf_hcap(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_TEMP: ',y%leaf_temp(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_FRACLIQ: ',y%leaf_fliq(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_ENERGY: ',y%leaf_energy(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_WATER: ',y%leaf_water(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' VEG_WIND: ',y%veg_wind(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LINT_SHV: ',y%lint_shv(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' MIN_LEAF_WATER:',rk4min_leaf_water + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_GBH: ',y%leaf_gbh(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_GBW: ',y%leaf_gbw(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_REYNOLDS: ',y%leaf_reynolds(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_GRASHOF: ',y%leaf_grashof(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_NUFREE: ',y%leaf_nussfree(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LEAF_NUFORC: ',y%leaf_nussforc(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' D(LEAF_EN)/Dt: ',dydx%leaf_energy(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' D(LEAF_WAT)/Dt:',dydx%leaf_water(ico) + write(unit=*,fmt='(a)') '========================================' + elseif (.not. record_err) then + return + end if + end if + end do leafloop + if(record_err .and. cflag7) integ_err(7,2) = integ_err(7,2) + 1_8 + if(record_err .and. cflag8) integ_err(8,2) = integ_err(8,2) + 1_8 + !------------------------------------------------------------------------------------! + + + + + !------------------------------------------------------------------------------------! + ! Check wood properties, but only for those cohorts with sufficient LAI. ! + !------------------------------------------------------------------------------------! + cpatch => csite%patch(ipa) + cflag9 = .false. + cflag10 = .false. + woodloop: do ico = 1,cpatch%ncohorts + if (.not. y%wood_resolvable(ico)) cycle woodloop + + !----- Find the minimum wood surface water. --------------------------------------! + rk4min_wood_water = rk4min_veg_lwater * y%wai(ico) + + !----- Check wood surface water. -------------------------------------------------! + if (y%wood_water(ico) < rk4min_wood_water) then + reject_step = .true. + if(record_err) cflag9 = .true. + if (print_problems) then + write(unit=*,fmt='(a)') '========================================' + write(unit=*,fmt='(a)') ' + Wood surface water is off-track...' + write(unit=*,fmt='(a)') '========================================' + write(unit=*,fmt='(a,1x,i6)') ' PFT: ',cpatch%pft(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' HEIGHT: ',cpatch%hite(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LAI: ',y%lai(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WAI: ',y%wai(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' TAI: ',y%tai(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' NPLANT: ',y%nplant(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' CROWN_AREA: ',y%crown_area(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_HCAP: ',y%wood_hcap(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_TEMP: ',y%wood_temp(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_FRACLIQ: ',y%wood_fliq(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_ENERGY: ',y%wood_energy(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_WATER: ',y%wood_water(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' VEG_WIND: ',y%veg_wind(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LINT_SHV: ',y%lint_shv(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' MIN_WOOD_WATER:',rk4min_wood_water + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_GBH: ',y%wood_gbh(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_GBW: ',y%wood_gbw(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_REYNOLDS: ',y%wood_reynolds(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_GRASHOF: ',y%wood_grashof(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_NUFREE: ',y%wood_nussfree(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_NUFORC: ',y%wood_nussforc(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' D(WOOD_EN)/Dt: ',dydx%wood_energy(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' D(WOOD_WAT)/Dt:',dydx%wood_water(ico) + write(unit=*,fmt='(a)') '========================================' + elseif (.not. record_err) then + return + end if + end if + + !----- Check wood temperature. ---------------------------------------------------! + if (y%wood_temp(ico) > rk4max_veg_temp .or. & + y%wood_temp(ico) < rk4min_veg_temp ) then + reject_step = .true. + if(record_err) cflag10 = .true. + if (print_problems) then + write(unit=*,fmt='(a)') '========================================' + write(unit=*,fmt='(a)') ' + Wood temperature is off-track...' + write(unit=*,fmt='(a)') '========================================' + write(unit=*,fmt='(a,1x,i6)') ' PFT: ',cpatch%pft(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' HEIGHT: ',cpatch%hite(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LAI: ',y%lai(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WAI: ',y%wai(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' TAI: ',y%tai(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' NPLANT: ',y%nplant(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' CROWN_AREA: ',y%crown_area(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_HCAP: ',y%wood_hcap(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_TEMP: ',y%wood_temp(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_FRACLIQ: ',y%wood_fliq(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_ENERGY: ',y%wood_energy(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_WATER: ',y%wood_water(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' VEG_WIND: ',y%veg_wind(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' LINT_SHV: ',y%lint_shv(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' MIN_WOOD_WATER:',rk4min_wood_water + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_GBH: ',y%wood_gbh(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_GBW: ',y%wood_gbw(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_REYNOLDS: ',y%wood_reynolds(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_GRASHOF: ',y%wood_grashof(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_NUFREE: ',y%wood_nussfree(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' WOOD_NUFORC: ',y%wood_nussforc(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' D(WOOD_EN)/Dt: ',dydx%wood_energy(ico) + write(unit=*,fmt='(a,1x,es12.4)') ' D(WOOD_WAT)/Dt:',dydx%wood_water(ico) + write(unit=*,fmt='(a)') '========================================' + elseif (.not. record_err) then + return + end if + end if + end do woodloop + if(record_err .and. cflag9 ) integ_err( 9,2) = integ_err( 9,2) + 1_8 + if(record_err .and. cflag10) integ_err(10,2) = integ_err(10,2) + 1_8 + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Check the water mass of the virtual pool. The energy is checked only when ! + ! there is enough mass. ! + !------------------------------------------------------------------------------------! + if (y%virtual_water < rk4min_virt_water) then + reject_step = .true. + if(record_err) integ_err(12,2) = integ_err(12,2) + 1_8 + if (print_problems) then + write(unit=*,fmt='(a)') '===========================================' + write(unit=*,fmt='(a)') ' + Virtual layer mass is off-track...' + write(unit=*,fmt='(a)') '-------------------------------------------' + write(unit=*,fmt='(a,1x,es12.4)') ' VIRTUAL_ENERGY: ',y%virtual_energy + write(unit=*,fmt='(a,1x,es12.4)') ' VIRTUAL_WATER: ',y%virtual_water + write(unit=*,fmt='(a,1x,es12.4)') ' VIRTUAL_DEPTH: ',y%virtual_depth + write(unit=*,fmt='(a,1x,es12.4)') ' VIRTUAL_TEMPK: ',y%virtual_tempk + write(unit=*,fmt='(a,1x,es12.4)') ' VIRTUAL_FLIQ : ',y%virtual_fracliq + write(unit=*,fmt='(a,1x,es12.4)') ' D(VIRT_WATER)/Dt: ',dydx%virtual_water + write(unit=*,fmt='(a,1x,es12.4)') ' D(VIRT_ENERGY)/Dt:',dydx%virtual_energy + write(unit=*,fmt='(a)') '===========================================' + elseif (.not. record_err) then + return + end if + elseif (y%virtual_water > 5.d-1 * rk4water_stab_thresh .and. & + (y%virtual_tempk < rk4min_sfcw_temp .or. y%virtual_tempk > rk4max_sfcw_temp)) & + then + reject_step = .true. + if(record_err) integ_err(11,2) = integ_err(11,2) + 1_8 + if (print_problems) then + write(unit=*,fmt='(a)') '===========================================' + write(unit=*,fmt='(a)') ' + Virtual layer temp. is off-track...' + write(unit=*,fmt='(a)') '-------------------------------------------' + write(unit=*,fmt='(a,1x,es12.4)') ' VIRTUAL_ENERGY: ',y%virtual_energy + write(unit=*,fmt='(a,1x,es12.4)') ' VIRTUAL_WATER: ',y%virtual_water + write(unit=*,fmt='(a,1x,es12.4)') ' VIRTUAL_DEPTH: ',y%virtual_depth + write(unit=*,fmt='(a,1x,es12.4)') ' VIRTUAL_TEMPK: ',y%virtual_tempk + write(unit=*,fmt='(a,1x,es12.4)') ' VIRTUAL_FLIQ : ',y%virtual_fracliq + write(unit=*,fmt='(a,1x,es12.4)') ' D(VIRT_WATER)/Dt: ',dydx%virtual_water + write(unit=*,fmt='(a,1x,es12.4)') ' D(VIRT_ENERGY)/Dt:',dydx%virtual_energy + write(unit=*,fmt='(a)') '===========================================' + elseif (.not. record_err) then + return + end if + return + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Checking whether the soil layers have decent moisture and temperatures. ! + !------------------------------------------------------------------------------------! + do k=rk4site%lsl,nzg + !----- Soil moisture -------------------------------------------------------------! + if (y%soil_water(k)< rk4min_soil_water(k) .or. & + y%soil_water(k)> rk4max_soil_water(k) ) then + reject_step = .true. + if(record_err) integ_err(osow+k,2) = integ_err(osow+k,2) + 1_8 + if (print_problems) then + write(unit=*,fmt='(a)') '========================================' + write(unit=*,fmt='(a)') ' + Soil layer water is off-track...' + write(unit=*,fmt='(a)') '----------------------------------------' + write(unit=*,fmt='(a,1x,i6)') ' Level: ',k + write(unit=*,fmt='(a,1x,f12.4)') ' H: ',h + write(unit=*,fmt='(a,1x,f12.4)') ' SOIL_TEMPK: ',y%soil_tempk(k) + write(unit=*,fmt='(a,1x,f12.4)') ' SOIL_FLIQ : ',y%soil_fracliq(k) + write(unit=*,fmt='(a,1x,f12.4)') ' SOIL_ENERGY: ',y%soil_energy(k) + write(unit=*,fmt='(a,1x,f12.4)') ' SOIL_WATER: ',y%soil_water(k) + write(unit=*,fmt='(a,1x,f12.4)') ' D(SOIL_E)/Dt:',dydx%soil_energy(k) + write(unit=*,fmt='(a,1x,f12.4)') ' D(SOIL_M)/Dt:',dydx%soil_water(k) + if (k == nzg .and. y%nlev_sfcwater > 0) then + write(unit=*,fmt='(a,1x,f12.4)') ' SFCW_TEMP: ',y%sfcwater_tempk(1) + write(unit=*,fmt='(a,1x,f12.4)') ' SFCW_ENERGY: ',y%sfcwater_energy(1) + write(unit=*,fmt='(a,1x,f12.4)') ' SFCW_MASS: ',y%sfcwater_mass(1) + write(unit=*,fmt='(a,1x,f12.4)') ' SFCW_DEPTH: ',y%sfcwater_depth(1) + write(unit=*,fmt='(a,1x,f12.4)') ' D(SFCW_E)/Dt:',dydx%sfcwater_energy(1) + write(unit=*,fmt='(a,1x,f12.4)') ' D(SFCW_M)/Dt:',dydx%sfcwater_mass(1) + end if + write(unit=*,fmt='(a)') '========================================' + elseif (.not. record_err) then + return + end if + end if + + !----- Soil temperature ----------------------------------------------------------! + if (y%soil_tempk(k) > rk4max_soil_temp .or. y%soil_tempk(k) < rk4min_soil_temp ) & + then + reject_step = .true. + if(record_err) integ_err(osoe+k,2) = integ_err(osoe+k,2) + 1_8 + if (print_problems) then + write(unit=*,fmt='(a)') '========================================' + write(unit=*,fmt='(a)') ' + Soil layer temp is off-track...' + write(unit=*,fmt='(a)') '----------------------------------------' + write(unit=*,fmt='(a,1x,i6)') ' Level: ',k + write(unit=*,fmt='(a,1x,f12.4)') ' H: ',h + write(unit=*,fmt='(a,1x,f12.4)') ' SOIL_TEMPK: ',y%soil_tempk(k) + write(unit=*,fmt='(a,1x,f12.4)') ' SOIL_FLIQ : ',y%soil_fracliq(k) + write(unit=*,fmt='(a,1x,f12.4)') ' SOIL_ENERGY: ',y%soil_energy(k) + write(unit=*,fmt='(a,1x,f12.4)') ' SOIL_WATER: ',y%soil_water(k) + write(unit=*,fmt='(a,1x,f12.4)') ' D(SOIL_E)/Dt:',dydx%soil_energy(k) + write(unit=*,fmt='(a,1x,f12.4)') ' D(SOIL_M)/Dt:',dydx%soil_water(k) + if (k == nzg .and. y%nlev_sfcwater > 0) then + write(unit=*,fmt='(a,1x,f12.4)') ' SFCW_TEMP: ',y%sfcwater_tempk(1) + write(unit=*,fmt='(a,1x,f12.4)') ' SFCW_ENERGY: ',y%sfcwater_energy(1) + write(unit=*,fmt='(a,1x,f12.4)') ' SFCW_MASS: ',y%sfcwater_mass(1) + write(unit=*,fmt='(a,1x,f12.4)') ' SFCW_DEPTH: ',y%sfcwater_depth(1) + write(unit=*,fmt='(a,1x,f12.4)') ' D(SFCW_E)/Dt:',dydx%sfcwater_energy(1) + write(unit=*,fmt='(a,1x,f12.4)') ' D(SFCW_M)/Dt:',dydx%sfcwater_mass(1) + end if + write(unit=*,fmt='(a)') '========================================' + elseif (.not. record_err) then + return + end if + end if + end do + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Check whether the temporary snow/water layer(s) has(ve) reasonable values. ! + !------------------------------------------------------------------------------------! + ksn = y%nlev_sfcwater + + do k=1, ksn + !----- Temperature ---------------------------------------------------------------! + if (y%sfcwater_tempk(k) < rk4min_sfcw_temp .or. & + y%sfcwater_tempk(k) > rk4max_sfcw_temp ) then + reject_step = .true. + if(record_err) integ_err(oswe+ksn,2) = integ_err(oswe+ksn,2) + 1_8 + if (print_problems) then + write(unit=*,fmt='(a)') '========================================' + write(unit=*,fmt='(a)') ' + Snow/pond temperature is off...' + write(unit=*,fmt='(a)') '----------------------------------------' + write(unit=*,fmt='(a,1x,i6)') ' This layer: ',k + write(unit=*,fmt='(a,1x,i6)') ' # of layers: ',y%nlev_sfcwater + write(unit=*,fmt='(a,1x,i6)') ' Stability flag:',y%flag_sfcwater + write(unit=*,fmt='(a,1x,f12.4)') ' SFCW_TEMP: ',y%sfcwater_tempk(k) + write(unit=*,fmt='(a,1x,f12.4)') ' SFCW_ENERGY: ',y%sfcwater_energy(k) + write(unit=*,fmt='(a,1x,f12.4)') ' SFCW_MASS: ',y%sfcwater_mass(k) + write(unit=*,fmt='(a,1x,f12.4)') ' SFCW_DEPTH: ',y%sfcwater_depth(k) + write(unit=*,fmt='(a,1x,f12.4)') ' D(SFCW_E)/Dt: ',dydx%sfcwater_energy(k) + write(unit=*,fmt='(a,1x,f12.4)') ' D(SFCW_M)/Dt: ',dydx%sfcwater_mass(k) + write(unit=*,fmt='(a)') '========================================' + elseif (.not. record_err) then + return + end if + end if + + !----- Mass ----------------------------------------------------------------------! + if (y%sfcwater_mass(k) < rk4min_sfcw_mass) then + reject_step = .true. + if(record_err) integ_err(oswm+ksn,2) = integ_err(oswm+ksn,2) + 1_8 + if (print_problems) then + write(unit=*,fmt='(a)') '========================================' + write(unit=*,fmt='(a)') ' + Snow/pond mass is off...' + write(unit=*,fmt='(a)') '----------------------------------------' + write(unit=*,fmt='(a,1x,i6)') ' This layer: ',k + write(unit=*,fmt='(a,1x,i6)') ' # of layers: ',y%nlev_sfcwater + write(unit=*,fmt='(a,1x,i6)') ' Stability flag:',y%flag_sfcwater + write(unit=*,fmt='(a,1x,f12.4)') ' SFCW_TEMP: ',y%sfcwater_tempk(k) + write(unit=*,fmt='(a,1x,f12.4)') ' SFCW_ENERGY: ',y%sfcwater_energy(k) + write(unit=*,fmt='(a,1x,f12.4)') ' SFCW_MASS: ',y%sfcwater_mass(k) + write(unit=*,fmt='(a,1x,f12.4)') ' SFCW_DEPTH: ',y%sfcwater_depth(k) + write(unit=*,fmt='(a,1x,f12.4)') ' D(SFCW_E)/Dt: ',dydx%sfcwater_energy(k) + write(unit=*,fmt='(a,1x,f12.4)') ' D(SFCW_M)/Dt: ',dydx%sfcwater_mass(k) + write(unit=*,fmt='(a)') '========================================' + elseif (.not. record_err) then + return + end if + end if + end do + !------------------------------------------------------------------------------------! + + if (reject_step .and. print_problems) then + + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(78a)') ('=',k=1,78) + write(unit=*,fmt='(a,1x,f12.4)') ' TIMESTEP: ',h + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' ---- SANITY CHECK BOUNDS ----' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' 1. CANOPY AIR SPACE: ' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(6(a,1x))') ' MIN_THEIV',' MAX_THEIV',' MIN_SHV' & + ,' MAX_SHV',' MIN_RHV',' MAX_RHV' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(4(a,1x))') ' MIN_TEMP',' MAX_TEMP',' MIN_THETA' & + ,' MAX_THETA' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(4(a,1x))') ' MIN_PRSS',' MAX_PRSS',' MIN_CO2' & + ,' MAX_CO2' + write(unit=*,fmt='(4(f12.5,1x))') rk4min_can_prss ,rk4max_can_prss & + ,rk4min_can_co2 ,rk4max_can_co2 + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(78a)') ('-',k=1,78) + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' 2. LEAF PROPERTIES: ' + write(unit=*,fmt='(3(a,1x))') ' MIN_TEMP',' MAX_TEMP',' MIN_LWATER' + write(unit=*,fmt='(3(f12.5,1x))') rk4min_veg_temp ,rk4max_veg_temp & + ,rk4min_veg_lwater + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(78a)') ('-',k=1,78) + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' 3. SURFACE WATER / VIRTUAL POOL PROPERTIES: ' + write(unit=*,fmt='(3(a,1x))') ' MIN_TEMP',' MAX_TEMP',' MIN_WMASS' + write(unit=*,fmt='(3(f12.5,1x))') rk4min_sfcw_temp ,rk4max_sfcw_temp & + ,rk4min_sfcw_mass + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(78a)') ('-',k=1,78) + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' 4. SOIL (TEXTURE CLASS AT TOP LAYER): ' + write(unit=*,fmt='(4(a,1x))') ' MIN_WATER',' MAX_WATER',' MIN_TEMP' & + ,' MAX_TEMP' + write(unit=*,fmt='(4(f12.5,1x))') rk4min_soil_water(nzg),rk4max_soil_water(nzg) & + ,rk4min_soil_temp ,rk4max_soil_temp + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(78a)') ('=',k=1,78) + write(unit=*,fmt='(a)') ' ' + end if + + return + end subroutine fb_sanity_check + + + + + + + + + + diff --git a/ED/src/dynamics/lsm_hyd.f90 b/ED/src/dynamics/lsm_hyd.f90 index 0c71e9f88..78db326d7 100644 --- a/ED/src/dynamics/lsm_hyd.f90 +++ b/ED/src/dynamics/lsm_hyd.f90 @@ -106,15 +106,15 @@ subroutine initHydroSubsurface() use grid_coms, only: ngrids,nzg use ed_misc_coms, only: dtlsm use ed_state_vars, only: edgrid_g,edtype,polygontype,sitetype - use consts_coms, only: wdns,cicevlme,tsupercool,t3ple,cliqvlme - use therm_lib, only: qwtk + use consts_coms, only: wdns,t3ple + use therm_lib, only: uextcm2tl, cmtl2uext implicit none type(edtype) , pointer :: cgrid type(polygontype) , pointer :: cpoly type(sitetype) , pointer :: csite integer :: igr, ipy, isi, ipa, k, nsoil,slsl - real :: zbar_site,area_poly,zmin + real :: zbar_site,area_poly,zmin,fliq !! SEE calcHydroSubsurface for variable definitions if(useTOPMODEL == 0) return @@ -179,18 +179,18 @@ subroutine initHydroSubsurface() end do !! reset energy do k = cpoly%lsl(isi),nzg - if(csite%soil_tempk(k,ipa) > t3ple)then - csite%soil_energy(k,ipa) = soil(nsoil)%slcpd & - * csite%soil_tempk(k,ipa) & - + csite%soil_water(k,ipa) * cliqvlme & - * (csite%soil_tempk(k,ipa) - tsupercool) + if (csite%soil_tempk(k,ipa) > t3ple) then + fliq = 1.0 + elseif (csite%soil_tempk(k,ipa) < t3ple) then + fliq = 0.0 else - csite%soil_energy(k,ipa) = soil(nsoil)%slcpd & - * csite%soil_tempk(k,ipa) & - + csite%soil_water(k,ipa) & - * cicevlme * csite%soil_tempk(k,ipa) + fliq = 0.5 end if + csite%soil_energy(k,ipa) = cmtl2uext( soil(nsoil)%slcpd & + , csite%soil_water(k,ipa) * wdns & + , csite%soil_tempk(k,ipa) & + , fliq ) end do call calcWatertable(cpoly,isi,ipa) enddo @@ -218,7 +218,7 @@ subroutine calcHydroSubsurface() use soil_coms, only: soil,slz,dslz use grid_coms, only: ngrids,nzg use ed_misc_coms, only: dtlsm - use therm_lib, only: qtk,qwtk + use therm_lib, only: uint2tl,uextcm2tl use consts_coms, only: wdns implicit none @@ -344,7 +344,7 @@ subroutine calcHydroSubsurface() !! Compute mean temperature and liquid fraction of soil water !! !! soil water converted from m3 -> kg !! !!*************************************************************************!! - call qwtk(soil_sat_energy,soil_sat_water*wdns,soil_sat_heat,tempk,fracliqtotal) + call uextcm2tl(soil_sat_energy,soil_sat_water*wdns,soil_sat_heat,tempk,fracliqtotal) !!*************************************************************************!! @@ -445,7 +445,7 @@ subroutine calcHydroSubsurface() !!**********************************************************************!! !! temperature and liquid fraction of water in flux !! !!**********************************************************************!! - call qtk(sheat/1000.0,tempk,fracliq) + call uint2tl(sheat/1000.0,tempk,fracliq) !!**********************************************************************!! !! Next, add water to other patches !! @@ -687,7 +687,7 @@ subroutine updateWatertableAdd(cpoly,isi,ipa,dw,sheat) use ed_state_vars, only: sitetype,polygontype use soil_coms, only: soil,slz,dslz,dslzi use grid_coms, only: nzg - use therm_lib, only: qwtk + use therm_lib, only: uextcm2tl use consts_coms, only: wdns implicit none type(polygontype) , target :: cpoly @@ -759,7 +759,7 @@ subroutine updateWatertableAdd(cpoly,isi,ipa,dw,sheat) !!***********************************************************************!! !! update soil temperature and liquid fraction !! !!***********************************************************************!! - call qwtk(csite%soil_energy(k,ipa),csite%soil_water(k,ipa)*wdns & + call uextcm2tl(csite%soil_energy(k,ipa),csite%soil_water(k,ipa)*wdns & ,soil(nsoil)%slcpd,tempk,fracliq) csite%soil_tempk(k,ipa) = tempk csite%soil_fracliq(k,ipa) = fracliq @@ -835,10 +835,10 @@ subroutine updateWatertableSubtract(cpoly,isi,ipa,dz,sheat,swater) use hydrology_constants use hydrology_coms, only: MoistSatThresh use ed_state_vars, only: polygontype, sitetype - use consts_coms, only : cliqvlme,wdns,tsupercool + use consts_coms, only : wdns use soil_coms, only: soil,slz,dslz,dslzi use grid_coms, only: nzg - use therm_lib, only : qwtk + use therm_lib, only : uextcm2tl,tl2uint implicit none type(polygontype), target :: cpoly @@ -893,7 +893,7 @@ subroutine updateWatertableSubtract(cpoly,isi,ipa,dz,sheat,swater) !!work down from saturation layer, removing water & heat do while (k >= cpoly%lsl(isi)) - call qwtk(csite%soil_energy(k,ipa),csite%soil_water(k,ipa)*1.e3,soil(nsoil)%slcpd,tempk,fracliq) + call uextcm2tl(csite%soil_energy(k,ipa),csite%soil_water(k,ipa)*1.e3,soil(nsoil)%slcpd,tempk,fracliq) !capacity for layer to loose moisture (unit = meters) wcap = (fracw - soil(nsoil)%soilcp/soil(nsoil)%slmsts) * dslz(k)*fracliq @@ -923,7 +923,7 @@ subroutine updateWatertableSubtract(cpoly,isi,ipa,dz,sheat,swater) endif !!update soil heat - dh = dw*cliqvlme*(tempk-tsupercool) + dh = dw * wdns * tl2uint(tempk,1.0) csite%soil_energy(k,ipa) = csite%soil_energy(k,ipa) + dh sheat = sheat - dh*dslz(k) !cumulative sum as return value swater = swater - dw*dslz(k) @@ -934,7 +934,7 @@ subroutine updateWatertableSubtract(cpoly,isi,ipa,dz,sheat,swater) !!update soil temperature - call qwtk(csite%soil_energy(k,ipa),csite%soil_water(k,ipa)*wdns & + call uextcm2tl(csite%soil_energy(k,ipa),csite%soil_water(k,ipa)*wdns & ,soil(nsoil)%slcpd,tempk,fracliq) csite%soil_tempk(k,ipa) = tempk csite%soil_fracliq(k,ipa) = fracliq @@ -965,8 +965,8 @@ subroutine updateWatertableBaseflow(cpoly,isi,ipa,baseflow) use ed_state_vars, only: polygontype, sitetype use soil_coms, only: soil,slz,dslz,dslzi,slcons1 use ed_misc_coms, only: dtlsm - use consts_coms, only: cliqvlme, tsupercool - use therm_lib, only : qwtk + use consts_coms, only: wdns + use therm_lib, only : uextcm2tl,tl2uint implicit none real, parameter :: freezeCoef = 7.0 !! should probably move to the com @@ -985,7 +985,7 @@ subroutine updateWatertableBaseflow(cpoly,isi,ipa,baseflow) slsl = cpoly%lsl(isi) !! determine freeze - call qwtk(csite%soil_energy(slsl,ipa),csite%soil_water(slsl,ipa)*1.e3,soil(nsoil)%slcpd,tempk,fracliq) + call uextcm2tl(csite%soil_energy(slsl,ipa),csite%soil_water(slsl,ipa)*1.e3,soil(nsoil)%slcpd,tempk,fracliq) freezeCor = fracliq if(freezeCor .lt. 1.0) freezeCor = 10.0**(-freezeCoef*(1.0-freezeCor)) @@ -1013,7 +1013,8 @@ subroutine updateWatertableBaseflow(cpoly,isi,ipa,baseflow) bf = bf + (csite%soil_water(slsl,ipa)-soil(nsoil)%soilcp)*dslz(slsl) csite%soil_water(slsl,ipa) = soil(nsoil)%soilcp end if - csite%soil_energy(slsl,ipa) = csite%soil_energy(slsl,ipa)-bf*cliqvlme*(csite%soil_tempk(slsl,ipa)-tsupercool) + csite%soil_energy(slsl,ipa) = csite%soil_energy(slsl,ipa) & + - bf*wdns*tl2uint(csite%soil_tempk(slsl,ipa),1.0) if(csite%soil_energy(slsl,ipa) /= csite%soil_energy(slsl,ipa)) then call fatal_error('Failed soil_energy sanity check in lsm_hyd' & @@ -1053,7 +1054,7 @@ subroutine writeHydro() use soil_coms , only : dslzi use ed_node_coms , only : mynum use consts_coms , only : t00 - use therm_lib , only : qtk + use therm_lib , only : uint2tl implicit none type(edtype) , pointer :: cgrid !Alias for "Current ED grid structure" @@ -1115,7 +1116,7 @@ subroutine writeHydro() area_land = 0.0 !calc temperature and liquid fraction of water in flux - call qtk(cgrid%sheat(ipy)*0.001,tempk,fracliq) + call uint2tl(cgrid%sheat(ipy)*0.001,tempk,fracliq) siteloop: do isi=1,cpoly%nsites @@ -1135,7 +1136,7 @@ subroutine writeHydro() if(useRUNOFF == 0) cgrid%runoff(ipy) = cgrid%runoff(ipy) + cpoly%area(isi)*cpoly%runoff(isi) area_land = area_land + cpoly%area(isi) if(isi == cpoly%nsites .and. useRUNOFF == 0) cgrid%runoff(ipy) = cgrid%runoff(ipy)/area_land - if(cpoly%runoff(isi) > 0.0) call qtk(cpoly%avg_runoff_heat(isi)/cpoly%runoff(isi),runoff_t,runoff_fl) + if(cpoly%runoff(isi) > 0.0) call uint2tl(cpoly%avg_runoff_heat(isi)/cpoly%runoff(isi),runoff_t,runoff_fl) do ipa=1,csite%npatches @@ -1206,9 +1207,9 @@ subroutine calcHydroSurface() use grid_coms, only: ngrids, nzg use ed_misc_coms, only: dtlsm use grid_coms,only:ngrids - use consts_coms, only : cliqvlme,cliq,t3ple,qicet3,qliqt3,tsupercool + use consts_coms, only : wdns,t3ple,uiicet3,uiliqt3 use soil_coms, only: water_stab_thresh - use therm_lib, only: qtk + use therm_lib, only: uint2tl,tl2uint implicit none type(edtype) , pointer :: cgrid type(polygontype) , pointer :: cpoly @@ -1263,17 +1264,17 @@ subroutine calcHydroSurface() top_surf_water = csite%nlev_sfcwater(ipa) if(top_surf_water > 0) then !second check that some is liquid - call qtk(csite%sfcwater_energy(top_surf_water,ipa),tempk,fracliq) + call uint2tl(csite%sfcwater_energy(top_surf_water,ipa),tempk,fracliq) if(fracliq > FracLiqRunoff) then !! calculate water depth swd_i = csite%sfcwater_mass(top_surf_water,ipa)*0.001*fracliq !convert liquid fraction from kg to meters surf_water_depth = swd_i - surf_water_heat = swd_i*cliqvlme*(tempk-tsupercool) + surf_water_heat = swd_i*wdns * tl2uint(tempk,1.0) do i=(top_surf_water-1),1,-1 - call qtk(csite%sfcwater_energy(i,ipa),tempk,fracliq) + call uint2tl(csite%sfcwater_energy(i,ipa),tempk,fracliq) swd_i = csite%sfcwater_mass(top_surf_water,ipa)*0.001*fracliq surf_water_depth = surf_water_depth + swd_i - surf_water_heat = surf_water_heat + swd_i*cliqvlme*(tempk-tsupercool) + surf_water_heat = surf_water_heat + swd_i*wdns*tl2uint(tempk,1.0) end do !!sanity check if(surf_water_depth > 1.0) then !!if there's more than 1 m of standing water @@ -1355,7 +1356,7 @@ subroutine calcHydroSurface() surf_water_depth = 0.0 top_surf_water = csite%nlev_sfcwater(ipa) do i=1,top_surf_water - call qtk(csite%sfcwater_energy(i,ipa),tempk,fracliq) + call uint2tl(csite%sfcwater_energy(i,ipa),tempk,fracliq) hts(i) = csite%sfcwater_mass(i,ipa)*0.001*fracliq surf_water_depth = surf_water_depth + hts(i) end do @@ -1396,7 +1397,7 @@ subroutine calcHydroSurface() !!if surface water is too small, keep in equilibrium with soil if(csite%sfcwater_mass(i,ipa) < water_stab_thresh & .and. i == 1) then - csite%sfcwater_energy(i,ipa) = cliq * (csite%soil_tempk(nzg,ipa)-tsupercool) + csite%sfcwater_energy(i,ipa) = tl2uint(csite%soil_tempk(nzg,ipa),1.0) end if end if !! if sfcwater_depth < amount of water, set to water depth @@ -1404,8 +1405,8 @@ subroutine calcHydroSurface() csite%sfcwater_depth(i,ipa) = csite%sfcwater_mass(i,ipa)*0.001 end if !! if sfcwater_energy < 0, set to freezing - if(csite%sfcwater_energy(i,ipa) < qicet3) then - csite%sfcwater_energy(i,ipa) = qliqt3 + if(csite%sfcwater_energy(i,ipa) < uiicet3) then + csite%sfcwater_energy(i,ipa) = uiliqt3 end if !!check for NaN if(csite%sfcwater_energy(i,ipa) /= csite%sfcwater_energy(i,ipa))then @@ -1549,7 +1550,7 @@ end subroutine calcHydroSurface !!!!!! use ed_misc_coms, only: dtlsm !!!!!! use ed_node_coms, only: master_num !!!!!! use const_coms, only : g, -!!!!!! use therm_lib, only: qtk +!!!!!! use therm_lib, only: uint2tl !!!!!! implicit none !!!!!! include "mpif.h" !!!!!! type(plist),dimension(ngrids) :: polygon_list @@ -1623,17 +1624,17 @@ end subroutine calcHydroSurface !!!!!! top_surf_water = cpatch%nlev_sfcwater !!!!!! if(top_surf_water .gt. 0) then !!!!!! !second check that some is liquid -!!!!!! call qtk(cpatch%sfcwater_energy(top_surf_water),tempk,fracliq) +!!!!!! call uint2tl(cpatch%sfcwater_energy(top_surf_water),tempk,fracliq) !!!!!! if(fracliq .gt. FracLiqRunoff) then !!!!!! !! water depth !!!!!! swd_i = cpatch%sfcwater_mass(top_surf_water)*0.001*fracliq !!!!!! surf_water_depth = swd_i -!!!!!! surf_water_heat = swd_i*cliqvlme*(tempk-tsupercool) +!!!!!! surf_water_heat = swd_i*wdns*tl2uint(tempk,1.0) !!!!!! do i=(top_surf_water-1),1,-1 -!!!!!! call qtk(cpatch%sfcwater_energy(i),tempk,fracliq) +!!!!!! call uint2tl(cpatch%sfcwater_energy(i),tempk,fracliq) !!!!!! swd_i = cpatch%sfcwater_mass(top_surf_water)*0.001*fracliq !!!!!! surf_water_depth = surf_water_depth + swd_i -!!!!!! surf_water_heat = surf_water_heat + swd_i*cliqvlme*(tempk-tsupercool) +!!!!!! surf_water_heat = surf_water_heat + swd_i*wdns*tl2uint(tempk,1.0) !!!!!! enddo !!!!!! !!!!!! !! calculate flow velocity (m/s) @@ -1716,7 +1717,7 @@ end subroutine calcHydroSurface !!!!!! top_surf_water = cpatch%nlev_sfcwater !!!!!! !!compute fraction to distribute to each layer !!!!!! do i=1,top_surf_water -!!!!!! call qtk(cpatch%sfcwater_energy(i),tempk,fracliq) +!!!!!! call uint2tl(cpatch%sfcwater_energy(i),tempk,fracliq) !!!!!! hts(i) = cpatch%sfcwater_mass(i)*0.001*fracliq !!!!!! surf_water_depth = surf_water_depth + hts(i) !!!!!! enddo @@ -1745,7 +1746,7 @@ end subroutine calcHydroSurface !!!!!! else !!!!!! !!if surface water is too small, keep in equilibrium with soil !!!!!! if(cpatch%sfcwater_mass(i) .lt. water_stab_thresh .and. i .eq. 1) then -!!!!!! cpatch%sfcwater_energy(i) = cliq*(cpatch%soil_tempk(nzg)-tsupercool) +!!!!!! cpatch%sfcwater_energy(i) = tl2uint(cpatch%soil_tempk(nzg),1.0) !!!!!! endif !!!!!! endif !!!!!! if(cpatch%sfcwater_depth(i) .lt. cpatch%sfcwater_mass(i)*0.001) then diff --git a/ED/src/dynamics/phenology_aux.f90 b/ED/src/dynamics/phenology_aux.f90 index 8ff37112a..3d3c43229 100644 --- a/ED/src/dynamics/phenology_aux.f90 +++ b/ED/src/dynamics/phenology_aux.f90 @@ -1,603 +1,633 @@ !==========================================================================================! !==========================================================================================! -! This subroutine calculates phenology factors for prescribed phenology schemes. ! +! This module contains sub-routines that are useful to determine phenology. ! !------------------------------------------------------------------------------------------! -subroutine prescribed_leaf_state(lat,imonth,iyear,doy,green_leaf_factor,leaf_aging_factor & - ,phen_pars) - - use phenology_coms , only : iphenys1 & ! intent(in) - , iphenysf & ! intent(in) - , iphenyf1 & ! intent(in) - , iphenyff & ! intent(in) - , prescribed_phen & ! intent(in) - , elongf_min ! ! intent(in) - use ed_max_dims , only : n_pft ! ! intent(in) - use pft_coms , only : phenology ! ! intent(in) +module phenology_aux + implicit none - !----- Arguments -----------------------------------------------------------------------! - type(prescribed_phen) , intent(in) :: phen_pars - integer , intent(in) :: iyear - integer , intent(in) :: doy - real , intent(in) :: lat - integer , intent(in) :: imonth - real, dimension(n_pft), intent(out) :: green_leaf_factor - real, dimension(n_pft), intent(out) :: leaf_aging_factor - !----- Local variables -----------------------------------------------------------------! - integer :: n_recycle_years - integer :: my_year - real :: elongf - real :: delay - real(kind=8) :: elonDen - integer :: pft - !---------------------------------------------------------------------------------------! - - !---------------------------------------------------------------------------------------! - ! This assumes dropping/flushing based on the day of year and hemisphere. ! - ! + Northern Hemisphere: dropping between August 1 and December 31; ! - ! flushing between January 1 and July 31. ! - ! + Southern Hemisphere: dropping between February 1 and July 31; ! - ! flushing between August 1 and January 31. ! - !---------------------------------------------------------------------------------------! - if( (lat >= 0.0 .and. imonth <= 7) .or. & - (lat < 0.0 .and. (imonth > 7 .or. imonth == 1)) )then - - !----- Get the year. ----------------------------------------------------------------! - n_recycle_years = iphenysf - iphenys1 + 1 + contains - if (iyear > iphenysf) then - my_year = mod(iyear-iphenys1,n_recycle_years) + 1 - elseif (iyear < iphenys1) then - my_year = n_recycle_years - mod(iphenysf-iyear,n_recycle_years) - else - my_year = iyear - iphenys1 + 1 - end if + !=======================================================================================! + !=======================================================================================! + ! This subroutine calculates phenology factors for prescribed phenology schemes. ! + !---------------------------------------------------------------------------------------! + subroutine prescribed_leaf_state(lat,imonth,iyear,doy,green_leaf_factor & + ,leaf_aging_factor,phen_pars) + + use phenology_coms , only : iphenys1 & ! intent(in) + , iphenysf & ! intent(in) + , iphenyf1 & ! intent(in) + , iphenyff & ! intent(in) + , prescribed_phen & ! intent(in) + , elongf_min ! ! intent(in) + use ed_max_dims , only : n_pft ! ! intent(in) + use pft_coms , only : phenology ! ! intent(in) + implicit none + !----- Arguments --------------------------------------------------------------------! + type(prescribed_phen) , intent(in) :: phen_pars + integer , intent(in) :: iyear + integer , intent(in) :: doy + real , intent(in) :: lat + integer , intent(in) :: imonth + real, dimension(n_pft), intent(out) :: green_leaf_factor + real, dimension(n_pft), intent(out) :: leaf_aging_factor + !----- Local variables --------------------------------------------------------------! + integer :: n_recycle_years + integer :: my_year + real :: elongf + real :: delay + real(kind=8) :: elonDen + integer :: pft !------------------------------------------------------------------------------------! - ! Calculate the factors. Precalc denominator and limit rate in order to ! - ! increase numerical stability (MCD 10/23/08). ! - !------------------------------------------------------------------------------------! - elonDen = real((phen_pars%flush_a(my_year) * real(doy)),kind=8) & - ** dble(max(phen_pars%flush_b(my_year),-100.)) - elonDen = 1.0d0 / (1.0d0 + elonDen) - if(elonDen < 0.0001d0) then - elongf = 0.0 - else - elongf = sngl(elonDen) - end if - delay = elongf - else + !------------------------------------------------------------------------------------! - ! Leaves turning color. Get the year. ! + ! This assumes dropping/flushing based on the day of year and hemisphere. ! + ! + Northern Hemisphere: dropping between August 1 and December 31; ! + ! flushing between January 1 and July 31. ! + ! + Southern Hemisphere: dropping between February 1 and July 31; ! + ! flushing between August 1 and January 31. ! !------------------------------------------------------------------------------------! - n_recycle_years = iphenyff - iphenyf1 + 1 - if (iyear > iphenyff) then - my_year = mod(iyear-iphenyf1,n_recycle_years) + 1 - elseif (iyear < iphenyf1) then - my_year = n_recycle_years - mod(iphenyff-iyear,n_recycle_years) + if( (lat >= 0.0 .and. imonth <= 7) .or. & + (lat < 0.0 .and. (imonth > 7 .or. imonth == 1)) )then + + !----- Get the year. -------------------------------------------------------------! + n_recycle_years = iphenysf - iphenys1 + 1 + + if (iyear > iphenysf) then + my_year = mod(iyear-iphenys1,n_recycle_years) + 1 + elseif (iyear < iphenys1) then + my_year = n_recycle_years - mod(iphenysf-iyear,n_recycle_years) + else + my_year = iyear - iphenys1 + 1 + end if + + !---------------------------------------------------------------------------------! + ! Calculate the factors. Precalc denominator and limit rate in order to ! + ! increase numerical stability (MCD 10/23/08). ! + !---------------------------------------------------------------------------------! + elonDen = real((phen_pars%flush_a(my_year) * real(doy)),kind=8) & + ** dble(max(phen_pars%flush_b(my_year),-100.)) + elonDen = 1.0d0 / (1.0d0 + elonDen) + if(elonDen < 0.0001d0) then + elongf = 0.0 + else + elongf = sngl(elonDen) + end if + delay = elongf else - my_year = iyear - iphenyf1 + 1 + !---------------------------------------------------------------------------------! + ! Leaves turning color. Get the year. ! + !---------------------------------------------------------------------------------! + n_recycle_years = iphenyff - iphenyf1 + 1 + if (iyear > iphenyff) then + my_year = mod(iyear-iphenyf1,n_recycle_years) + 1 + elseif (iyear < iphenyf1) then + my_year = n_recycle_years - mod(iphenyff-iyear,n_recycle_years) + else + my_year = iyear - iphenyf1 + 1 + end if + + !----- Calculate the factors. ----------------------------------------------------! + elongf = 1.0 & + / (1.0 + (phen_pars%color_a(my_year) * real(doy)) & + ** phen_pars%color_b(my_year)) + delay = 1.0 & + / (1.0 + (phen_pars%color_a(my_year) * real(doy) * 1.095) & + ** phen_pars%color_b(my_year)) end if - !----- Calculate the factors. -------------------------------------------------------! - elongf = 1.0 & - / (1.0 + (phen_pars%color_a(my_year) * real(doy))**phen_pars%color_b(my_year)) - delay = 1.0 & - / (1.0 + (phen_pars%color_a(my_year) * real(doy) * 1.095) & - **phen_pars%color_b(my_year)) - end if - - if(elongf < elongf_min) elongf = 0.0 - - !----- Load the values for each PFT. ---------------------------------------------------! - do pft = 1, n_pft - select case (phenology(pft)) - case (2) - green_leaf_factor(pft) = elongf - leaf_aging_factor(pft) = delay - case default - green_leaf_factor(pft) = 1.0 - leaf_aging_factor(pft) = 1.0 - end select - end do - - return -end subroutine prescribed_leaf_state -!==========================================================================================! -!==========================================================================================! + if(elongf < elongf_min) elongf = 0.0 + !----- Load the values for each PFT. ------------------------------------------------! + do pft = 1, n_pft + select case (phenology(pft)) + case (2) + green_leaf_factor(pft) = elongf + leaf_aging_factor(pft) = delay + case default + green_leaf_factor(pft) = 1.0 + leaf_aging_factor(pft) = 1.0 + end select + end do + + return + end subroutine prescribed_leaf_state + !=======================================================================================! + !=======================================================================================! -!==========================================================================================! -!==========================================================================================! -! This subroutine computes the number of chill and warming days in a month. ! -! + Chill days - number of days with average temperatures below 278.15 K; ! -! + Degree days - sum of daily average temperatures above 278.15 K. ! -!------------------------------------------------------------------------------------------! -subroutine update_thermal_sums(month, cpoly, isi, lat) - - use ed_state_vars ,only : polygontype & ! structure - , sitetype ! ! structure - implicit none - !----- Arguments -----------------------------------------------------------------------! - type(polygontype) , target :: cpoly - integer , intent(in) :: isi - integer , intent(in) :: month - real , intent(in) :: lat - !----- Local variables -----------------------------------------------------------------! - type(sitetype) , pointer :: csite - integer :: ipa + + !=======================================================================================! + !=======================================================================================! + ! This subroutine computes the number of chill and warming days in a month. ! + ! + Chill days - number of days with average temperatures below 278.15 K; ! + ! + Degree days - sum of daily average temperatures above 278.15 K. ! !---------------------------------------------------------------------------------------! + subroutine update_thermal_sums(month, cpoly, isi, lat) + + use ed_state_vars ,only : polygontype & ! structure + , sitetype ! ! structure + implicit none + !----- Arguments --------------------------------------------------------------------! + type(polygontype) , target :: cpoly + integer , intent(in) :: isi + integer , intent(in) :: month + real , intent(in) :: lat + !----- Local variables --------------------------------------------------------------! + type(sitetype) , pointer :: csite + integer :: ipa + !------------------------------------------------------------------------------------! - !----- Loop over patches. --------------------------------------------------------------! - csite => cpoly%site(isi) + !----- Loop over patches. -----------------------------------------------------------! + csite => cpoly%site(isi) - do ipa = 1,csite%npatches + do ipa = 1,csite%npatches - !----- Minimum monthly temperature of the site. -------------------------------------! - cpoly%min_monthly_temp(isi) = min(cpoly%min_monthly_temp(isi) & - ,csite%avg_daily_temp(ipa)) + !----- Minimum monthly temperature of the site. ----------------------------------! + cpoly%min_monthly_temp(isi) = min(cpoly%min_monthly_temp(isi) & + ,csite%avg_daily_temp(ipa)) - !----- Warm day, so check whether it is growing season and update the degree day... -! - if (csite%avg_daily_temp(ipa) > 278.15) then - !----- Update dgd only for growing season. ---------------------------------------! - if ((lat >= 0.0 .and. month <= 8) .or. & - (lat < 0.0 .and. (month <= 2 .or. month >= 7))) then - csite%sum_dgd(ipa) = csite%sum_dgd(ipa) + (csite%avg_daily_temp(ipa)-278.15) - !----- Warm day during dropping season, set degree sum to zero... ----------------! + !---------------------------------------------------------------------------------! + ! Warm day, so check whether it is growing season and update the degree day... ! + !---------------------------------------------------------------------------------! + if (csite%avg_daily_temp(ipa) > 278.15) then + !----- Update dgd only for growing season. ------------------------------------! + if ((lat >= 0.0 .and. month <= 8) .or. & + (lat < 0.0 .and. (month <= 2 .or. month >= 7))) then + csite%sum_dgd(ipa) = csite%sum_dgd(ipa) + (csite%avg_daily_temp(ipa)-278.15) + !----- Warm day during dropping season, set degree sum to zero... -------------! + else + csite%sum_dgd(ipa) = 0.0 + end if + !---- Cold day, check whether it is dropping season and update chilling days... --! + elseif ((lat >= 0.0 .and. (month >= 11 .or. month <= 6)) .or. & + (lat < 0.0 .and. month >= 5) ) then + csite%sum_chd(ipa) = csite%sum_chd(ipa) + 1.0 + !---- Cold day, but not during dropping season, set chilling days to zero... -----! else - csite%sum_dgd(ipa) = 0.0 + csite%sum_chd(ipa) = 0.0 end if - !---- Cold day, check whether it is dropping season and update chilling days... -----! - elseif ((lat >= 0.0 .and. (month >= 11 .or. month <= 6)) .or. & - (lat < 0.0 .and. month >= 5) ) then - csite%sum_chd(ipa) = csite%sum_chd(ipa) + 1.0 - !---- Cold day, but not during dropping season, set chilling days to zero... --------! - else - csite%sum_chd(ipa) = 0.0 - end if - end do - - return -end subroutine update_thermal_sums -!==========================================================================================! -!==========================================================================================! - + end do + + return + end subroutine update_thermal_sums + !=======================================================================================! + !=======================================================================================! -!==========================================================================================! -!==========================================================================================! -! This subroutine updates the turnover ratio and specific leaf area, taking into ! -! account the available radiation. ! -!------------------------------------------------------------------------------------------! -subroutine update_turnover(cpoly, isi) - use ed_state_vars , only : polygontype & ! structure - , sitetype & ! structure - , patchtype ! ! structure - use pft_coms , only : is_tropical & ! intent(in) - , phenology & ! intent(in) - , SLA & ! intent(in) - , sla_scale & ! intent(in) - , sla_inter & ! intent(in) - , sla_slope & ! intent(in) - , leaf_turnover_rate ! ! intent(in) - use phenology_coms , only : radint & ! intent(in) - , radslp & ! intent(in) - , turnamp_window & ! intent(out) - , turnamp_wgt & ! intent(out) - , turnamp_min & ! intent(out) - , turnamp_max & ! intent(out) - , radto_min & ! intent(out) - , radto_max & ! intent(out) - , llspan_window & ! intent(out) - , llspan_wgt & ! intent(out) - , llspan_min & ! intent(out) - , llspan_max & ! intent(out) - , llspan_inf & ! intent(out) - , vm0_window & ! intent(out) - , vm0_wgt & ! intent(out) - , vm0_tran & ! intent(out) - , vm0_slope & ! intent(out) - , vm0_amp & ! intent(out) - , vm0_min ! ! intent(out) - use consts_coms , only : day_sec ! ! intent(in) - implicit none - !----- Arguments -----------------------------------------------------------------------! - type(polygontype) , target :: cpoly - integer , intent(in) :: isi - !----- Local variables -----------------------------------------------------------------! - type(sitetype) , pointer :: csite - type(patchtype) , pointer :: cpatch - integer :: ipa - integer :: ico - integer :: ipft - real :: turnover_now - real :: turnamp_now - real :: llspan_now - real :: vm0_now + !=======================================================================================! + !=======================================================================================! + ! This subroutine updates the turnover ratio and specific leaf area, taking into ! + ! account the available radiation. ! !---------------------------------------------------------------------------------------! + subroutine update_turnover(cpoly, isi) + use ed_state_vars , only : polygontype & ! structure + , sitetype & ! structure + , patchtype ! ! structure + use pft_coms , only : is_tropical & ! intent(in) + , phenology & ! intent(in) + , SLA & ! intent(in) + , sla_scale & ! intent(in) + , sla_inter & ! intent(in) + , sla_slope & ! intent(in) + , leaf_turnover_rate ! ! intent(in) + use phenology_coms , only : radint & ! intent(in) + , radslp & ! intent(in) + , turnamp_window & ! intent(out) + , turnamp_wgt & ! intent(out) + , turnamp_min & ! intent(out) + , turnamp_max & ! intent(out) + , radto_min & ! intent(out) + , radto_max & ! intent(out) + , llspan_window & ! intent(out) + , llspan_wgt & ! intent(out) + , llspan_min & ! intent(out) + , llspan_max & ! intent(out) + , llspan_inf & ! intent(out) + , vm0_window & ! intent(out) + , vm0_wgt & ! intent(out) + , vm0_tran & ! intent(out) + , vm0_slope & ! intent(out) + , vm0_amp & ! intent(out) + , vm0_min ! ! intent(out) + use consts_coms , only : day_sec ! ! intent(in) + + implicit none + !----- Arguments --------------------------------------------------------------------! + type(polygontype) , target :: cpoly + integer , intent(in) :: isi + !----- Local variables --------------------------------------------------------------! + type(sitetype) , pointer :: csite + type(patchtype) , pointer :: cpatch + integer :: ipa + integer :: ico + integer :: ipft + real :: turnover_now + real :: turnamp_now + real :: llspan_now + real :: vm0_now + !------------------------------------------------------------------------------------! - !----- Loop over patches. --------------------------------------------------------------! - csite => cpoly%site(isi) - patchloop: do ipa = 1,csite%npatches - - cpatch => csite%patch(ipa) - cohortloop: do ico = 1,cpatch%ncohorts + !----- Loop over patches. -----------------------------------------------------------! + csite => cpoly%site(isi) + patchloop: do ipa = 1,csite%npatches + + cpatch => csite%patch(ipa) + cohortloop: do ico = 1,cpatch%ncohorts - ipft = cpatch%pft(ico) + ipft = cpatch%pft(ico) - !---------------------------------------------------------------------------------! - ! We must check whether the light phenology is to be applied for this PFT. ! - !---------------------------------------------------------------------------------! - select case (phenology(ipft)) - case (3) !------------------------------------------------------------------------------! - ! Find the target turnover rate amplitude (turnamp_now). ! - !------------------------------------------------------------------------------! - if (cpoly%rad_avg(isi) <= radto_min) then - turnamp_now = turnamp_min - elseif (cpoly%rad_avg(isi) >= radto_max) then - turnamp_now = turnamp_max - else - turnamp_now = radint + radslp * cpoly%rad_avg(isi) - end if + ! We must check whether the light phenology is to be applied for this PFT. ! !------------------------------------------------------------------------------! + select case (phenology(ipft)) + case (3) + !---------------------------------------------------------------------------! + ! Find the target turnover rate amplitude (turnamp_now). ! + !---------------------------------------------------------------------------! + if (cpoly%rad_avg(isi) <= radto_min) then + turnamp_now = turnamp_min + elseif (cpoly%rad_avg(isi) >= radto_max) then + turnamp_now = turnamp_max + else + turnamp_now = radint + radslp * cpoly%rad_avg(isi) + end if + !---------------------------------------------------------------------------! - !------ The actual turnover amplitude is based on a running average. ----------! - cpatch%turnover_amp(ico) = (1.0 - turnamp_wgt) * cpatch%turnover_amp(ico) & - + turnamp_wgt * turnamp_now - !------------------------------------------------------------------------------! + !------ The actual turnover amplitude is based on a running average. -------! + cpatch%turnover_amp(ico) = (1.0 - turnamp_wgt) * cpatch%turnover_amp(ico) & + + turnamp_wgt * turnamp_now + !---------------------------------------------------------------------------! - !------------------------------------------------------------------------------! - ! Update target leaf lifespan. ! - !------------------------------------------------------------------------------! - if (leaf_turnover_rate(ipft) > 0.) then - llspan_now = 12.0 / (cpatch%turnover_amp(ico) * leaf_turnover_rate(ipft)) - !----- Make sure the life span is bounded. ---------------------------------! - if ( llspan_now < llspan_min) then - llspan_now = llspan_min - elseif (llspan_now > llspan_max) then - llspan_now = llspan_max - end if !---------------------------------------------------------------------------! - else - !---- Nothing lasts forever, so impose a maximum life span. ----------------! - llspan_now = llspan_inf + ! Update target leaf lifespan. ! + !---------------------------------------------------------------------------! + if (leaf_turnover_rate(ipft) > 0.) then + llspan_now = 12.0 / (cpatch%turnover_amp(ico) * leaf_turnover_rate(ipft)) + !----- Make sure the life span is bounded. ------------------------------! + if ( llspan_now < llspan_min) then + llspan_now = llspan_min + elseif (llspan_now > llspan_max) then + llspan_now = llspan_max + end if + !------------------------------------------------------------------------! + else + !---- Nothing lasts forever, so impose a maximum life span. -------------! + llspan_now = llspan_inf + !------------------------------------------------------------------------! + end if !---------------------------------------------------------------------------! - end if - !------------------------------------------------------------------------------! - - !------------------------------------------------------------------------------! - ! The actual leaf lifespan is the weighted average. ! - !------------------------------------------------------------------------------! - cpatch%llspan(ico) = (1.0 - llspan_wgt) * cpatch%llspan(ico) & - + llspan_wgt * llspan_now - !------------------------------------------------------------------------------! - + !---------------------------------------------------------------------------! + ! The actual leaf lifespan is the weighted average. ! + !---------------------------------------------------------------------------! + cpatch%llspan(ico) = (1.0 - llspan_wgt) * cpatch%llspan(ico) & + + llspan_wgt * llspan_now + !---------------------------------------------------------------------------! - !----- Update the running average of the photosythetic capacity (Vm0). --------! - vm0_now = vm0_amp / (1.0 + (cpatch%llspan(ico) / vm0_tran)**vm0_slope) & - + vm0_min - cpatch%vm_bar(ico) = (1.0 - vm0_wgt) * cpatch%vm_bar(ico) + vm0_wgt * vm0_now - !------------------------------------------------------------------------------! + !----- Update the running average of the photosythetic capacity (Vm0). -----! + vm0_now = vm0_amp / (1.0 + (cpatch%llspan(ico) / vm0_tran)**vm0_slope) & + + vm0_min + cpatch%vm_bar(ico) = (1.0 - vm0_wgt) * cpatch%vm_bar(ico) & + + vm0_wgt * vm0_now + !---------------------------------------------------------------------------! - !----- Update the specific leaf area (SLA). -----------------------------------! - turnover_now = cpatch%turnover_amp(ico) * leaf_turnover_rate(ipft) - cpatch%sla(ico) = 10.0 ** ( sla_inter & - + sla_slope * log10( 12.0 / turnover_now ) ) & - * sla_scale - case default - !----- The default is to keep these variables the same. -----------------------! - continue - !------------------------------------------------------------------------------! - end select - end do cohortloop - end do patchloop - return -end subroutine update_turnover -!==========================================================================================! -!==========================================================================================! + !----- Update the specific leaf area (SLA). --------------------------------! + turnover_now = cpatch%turnover_amp(ico) * leaf_turnover_rate(ipft) + cpatch%sla(ico) = 10.0 ** ( sla_inter & + + sla_slope * log10( 12.0 / turnover_now ) ) & + * sla_scale + case default + !----- The default is to keep these variables the same. --------------------! + continue + !---------------------------------------------------------------------------! + end select + end do cohortloop + end do patchloop + return + end subroutine update_turnover + !=======================================================================================! + !=======================================================================================! -!==========================================================================================! -!==========================================================================================! -! This sub-routine will assign the initial potential available water and the ! -! phenology that has been assigned. This sub-routine should be called whenever a new ! -! cohort is created, or at the initial run (except history). The initial running average ! -! is simply the the instantaneous soil moisture variable. For plants other than the ! -! drought-deciduous, the potential available water is found but it doesn't control the ! -! phenology, so we assign fully flushed leaves. ! -!------------------------------------------------------------------------------------------! -subroutine first_phenology(cgrid) - use ed_state_vars , only : edtype & ! structure - , polygontype & ! structure - , sitetype & ! structure - , patchtype ! ! structure - use ed_therm_lib , only : calc_veg_hcap ! ! function - use allometry , only : area_indices ! ! subroutine - use grid_coms , only : nzg ! ! intent(in) - implicit none - !----- Arguments -----------------------------------------------------------------------! - type(edtype) , target :: cgrid ! Current grid - !----- Local variables -----------------------------------------------------------------! - type(polygontype), pointer :: cpoly ! Current polygon - type(sitetype) , pointer :: csite ! Current site - type(patchtype) , pointer :: cpatch ! Current patch - integer :: ipy ! Polygon counter - integer :: isi ! Site counter - integer :: ipa ! Patch counter - integer :: ico ! Cohort counter - !---------------------------------------------------------------------------------------! + !=======================================================================================! + !=======================================================================================! + ! This sub-routine will assign the initial potential available water and the ! + ! phenology that has been assigned. This sub-routine should be called whenever a new ! + ! cohort is created, or at the initial run (except history). The initial running aver- ! + ! age is simply the the instantaneous soil moisture variable. For plants other than ! + ! the drought-deciduous, the potential available water is found but it doesn't control ! + ! the phenology, so we assign fully flushed leaves. ! !---------------------------------------------------------------------------------------! - ! Loop over all cohorts in this grid. ! - !---------------------------------------------------------------------------------------! - polyloop: do ipy=1,cgrid%npolygons - cpoly => cgrid%polygon(ipy) - siteloop: do isi=1,cpoly%nsites - csite => cpoly%site(isi) - patchloop: do ipa=1,csite%npatches - cpatch => csite%patch(ipa) - cohortloop: do ico=1,cpatch%ncohorts + subroutine first_phenology(cgrid) + use ed_state_vars , only : edtype & ! structure + , polygontype & ! structure + , sitetype & ! structure + , patchtype ! ! structure + use ed_therm_lib , only : calc_veg_hcap ! ! function + use ed_max_dims , only : n_pft ! ! intent(in) + use allometry , only : area_indices ! ! subroutine + use grid_coms , only : nzg ! ! intent(in) + implicit none + !----- Arguments --------------------------------------------------------------------! + type(edtype) , target :: cgrid ! Current grid + !----- Local variables --------------------------------------------------------------! + type(polygontype) , pointer :: cpoly ! Current polygon + type(sitetype) , pointer :: csite ! Current site + type(patchtype) , pointer :: cpatch ! Current patch + integer :: ipy ! Polygon counter + integer :: isi ! Site counter + integer :: ipa ! Patch counter + integer :: ico ! Cohort counter + !------------------------------------------------------------------------------------! - !---------------------------------------------------------------------------! - ! Find the initial guess for potential available water and elongation ! - ! factor, then compute the equilibrium biomass of active tissues and ! - ! storage. ! - !---------------------------------------------------------------------------! - call pheninit_balive_bstorage(nzg,csite,ipa,ico,cpoly%ntext_soil(:,isi) & - ,cpoly%green_leaf_factor(:,isi)) - !---------------------------------------------------------------------------! - !----- Find LAI, WPA, WAI. -------------------------------------------------! - call area_indices(cpatch%nplant(ico),cpatch%bleaf(ico),cpatch%bdead(ico) & - ,cpatch%balive(ico),cpatch%dbh(ico),cpatch%hite(ico) & - ,cpatch%pft(ico),cpatch%sla(ico),cpatch%lai(ico) & - ,cpatch%wpa(ico),cpatch%wai(ico),cpatch%crown_area(ico) & - ,cpatch%bsapwood(ico)) - !---------------------------------------------------------------------------! + !------------------------------------------------------------------------------------! + ! Loop over all sites in this grid. ! + !------------------------------------------------------------------------------------! + polyloop: do ipy=1,cgrid%npolygons + nullify(cpoly) + cpoly => cgrid%polygon(ipy) + siteloop: do isi=1,cpoly%nsites + csite => cpoly%site(isi) - !----- Find heat capacity and vegetation internal energy. ------------------! - call calc_veg_hcap(cpatch%bleaf(ico),cpatch%bdead(ico),cpatch%bsapwood(ico) & - ,cpatch%nplant(ico),cpatch%pft(ico) & - ,cpatch%leaf_hcap(ico),cpatch%wood_hcap(ico) ) - cpatch%leaf_energy(ico) = cpatch%leaf_hcap(ico) * cpatch%leaf_temp(ico) - cpatch%wood_energy(ico) = cpatch%wood_hcap(ico) * cpatch%wood_temp(ico) - call is_resolvable(csite,ipa,ico,cpoly%green_leaf_factor(:,isi)) + !------------------------------------------------------------------------------! + ! Loop over all patches and cohorts. ! + !------------------------------------------------------------------------------! + patchloop: do ipa=1,csite%npatches + cpatch => csite%patch(ipa) + cohortloop: do ico=1,cpatch%ncohorts + + !------------------------------------------------------------------------! + ! Find the initial guess for potential available water and elongation ! + ! factor, then compute the equilibrium biomass of active tissues and ! + ! storage. ! + !------------------------------------------------------------------------! + call pheninit_balive_bstorage(nzg,cpatch%pft(ico),cpatch%krdepth(ico) & + ,cpatch%hite(ico),cpatch%dbh(ico) & + ,csite%soil_water(:,ipa) & + ,cpoly%ntext_soil(:,isi) & + ,cpoly%green_leaf_factor(:,isi) & + ,cpatch%paw_avg(ico),cpatch%elongf(ico) & + ,cpatch%phenology_status(ico) & + ,cpatch%bleaf(ico),cpatch%broot(ico) & + ,cpatch%bsapwood(ico),cpatch%balive(ico) & + ,cpatch%bstorage(ico)) + !------------------------------------------------------------------------! + + + !----- Find LAI, WAI, and CAI. ------------------------------------------! + call area_indices(cpatch%nplant(ico),cpatch%bleaf(ico),cpatch%bdead(ico) & + ,cpatch%balive(ico),cpatch%dbh(ico),cpatch%hite(ico) & + ,cpatch%pft(ico),cpatch%sla(ico),cpatch%lai(ico) & + ,cpatch%wai(ico),cpatch%crown_area(ico) & + ,cpatch%bsapwood(ico)) + !------------------------------------------------------------------------! + + + !----- Find heat capacity and vegetation internal energy. ---------------! + call calc_veg_hcap(cpatch%bleaf(ico),cpatch%bdead(ico) & + ,cpatch%bsapwood(ico),cpatch%nplant(ico) & + ,cpatch%pft(ico) & + ,cpatch%leaf_hcap(ico),cpatch%wood_hcap(ico) ) + cpatch%leaf_energy(ico) = cpatch%leaf_hcap(ico) * cpatch%leaf_temp(ico) + cpatch%wood_energy(ico) = cpatch%wood_hcap(ico) * cpatch%wood_temp(ico) + call is_resolvable(csite,ipa,ico,cpoly%green_leaf_factor(:,isi)) + !------------------------------------------------------------------------! + end do cohortloop !---------------------------------------------------------------------------! + end do patchloop + !------------------------------------------------------------------------------! + end do siteloop + !---------------------------------------------------------------------------------! + end do polyloop + !------------------------------------------------------------------------------------! - - end do cohortloop - end do patchloop - end do siteloop - end do polyloop - - return -end subroutine first_phenology -!==========================================================================================! -!==========================================================================================! + return + end subroutine first_phenology + !=======================================================================================! + !=======================================================================================! -!==========================================================================================! -!==========================================================================================! -! This sub-routine will assign the initial potential available water and the ! -! phenology that has been assigned, then find the biomass of active tissues and storage ! -! that is in equilibrium with the initial soil moisture. This sub-routine should be ! -! called whenever a new cohort is planted or recruited, or at the initial run (except ! -! history). The initial running average is simply the the instantaneous soil moisture ! -! variable. For plants other than the drought-deciduous, the potential available water is ! -! found but it doesn't control the phenology, so we assign the biomass that matches the ! -! fully flushed leaves. ! -!------------------------------------------------------------------------------------------! -subroutine pheninit_balive_bstorage(mzg,csite,ipa,ico,ntext_soil,green_leaf_factor) - use ed_misc_coms , only : ivegt_dynamics ! ! intent(in) - use ed_state_vars , only : sitetype & ! structure - , patchtype ! ! structure - use soil_coms , only : soil & ! intent(in), look-up table - , slz & ! intent(in) - , dslz ! ! intent(in) - use phenology_coms, only : spot_phen & ! intent(in) - , elongf_min ! ! intent(in) - use pft_coms , only : phenology & ! intent(in) - , q & ! intent(in) - , qsw ! ! intent(in) - use ed_max_dims , only : n_pft ! ! intent(in) - use allometry , only : dbh2bl ! ! function - implicit none - !----- Arguments -----------------------------------------------------------------------! - type(sitetype) , target :: csite ! Current site - integer , intent(in) :: mzg ! # of soil layers - integer , intent(in) :: ipa ! Current patch - integer , intent(in) :: ico ! Cohort counter - integer , dimension(mzg) , intent(in) :: ntext_soil ! Soil texture - real , dimension(n_pft), intent(in) :: green_leaf_factor ! Hardwood phenology - !----- Local variables -----------------------------------------------------------------! - type(patchtype) , pointer :: cpatch ! Current patch - integer :: k ! Layer counter - integer :: ipft ! PFT type - integer :: nsoil ! Alias for soil texture class - real :: salloc ! balive:bleaf ratio - real :: salloci ! bleaf:balive ratio - real :: bleaf_max ! maximum bleaf - real :: balive_max ! balive if on-allometry - real :: psi_layer ! Water potential of this layer - real :: psi_wilt ! Wilting point potential - real :: psi_crit ! Critical point potential + !=======================================================================================! + !=======================================================================================! + ! This sub-routine will assign the initial potential available water and the ! + ! phenology that has been assigned, then find the biomass of active tissues and storage ! + ! that is in equilibrium with the initial soil moisture. This sub-routine should be ! + ! called whenever a new cohort is planted or recruited, or at the initial run (except ! + ! history). The initial running average is simply the the instantaneous soil moisture ! + ! variable. For plants other than the drought-deciduous, the potential available water ! + ! is found but it doesn't control the phenology, so we assign the biomass that matches ! + ! the fully flushed leaves. ! !---------------------------------------------------------------------------------------! + subroutine pheninit_balive_bstorage(mzg,ipft,kroot,height,dbh,soil_water,ntext_soil & + ,green_leaf_factor,paw_avg,elongf,phenology_status & + ,bleaf,broot,bsapwood,balive,bstorage) + use soil_coms , only : soil & ! intent(in), look-up table + , slz & ! intent(in) + , slzt & ! intent(in) + , dslz ! ! intent(in) + use phenology_coms, only : spot_phen & ! intent(in) + , elongf_min ! ! intent(in) + use pft_coms , only : phenology & ! intent(in) + , q & ! intent(in) + , qsw ! ! intent(in) + use ed_max_dims , only : n_pft ! ! intent(in) + use allometry , only : dbh2bl & ! function + , h2crownbh ! ! function + implicit none + !----- Arguments --------------------------------------------------------------------! + integer , intent(in) :: mzg ! # of soil layers + integer , intent(in) :: ipft ! PFT type + integer , intent(in) :: kroot ! Level of rooting depth + real , intent(in) :: height ! Height + real , intent(in) :: dbh ! DBH + integer, dimension(mzg) , intent(in) :: ntext_soil ! Soil texture + real , dimension(mzg) , intent(in) :: soil_water ! Soil water + real , dimension(n_pft), intent(in) :: green_leaf_factor ! Hardwood phenology + real , intent(out) :: paw_avg ! Pot. available water + real , intent(out) :: elongf ! Elongation factor + integer , intent(out) :: phenology_status ! phenology Flag + real , intent(out) :: bleaf ! Leaf biomass + real , intent(out) :: broot ! Root biomass + real , intent(out) :: bsapwood ! Sapwood biomass + real , intent(out) :: balive ! Living tissue biomass + real , intent(out) :: bstorage ! Storage biomass + !----- Local variables --------------------------------------------------------------! + integer :: k ! Layer counter + integer :: nsoil ! Soil texture class + real :: salloc ! balive:bleaf ratio + real :: salloci ! bleaf:balive ratio + real :: bleaf_max ! maximum bleaf + real :: balive_max ! balive if on-allometry + real :: psi_layer ! Water pot. of this layer + real :: psi_wilt ! Wilting point potential + real :: psi_crit ! Critical point potential + real :: mcheight ! Mid-crown height + !------------------------------------------------------------------------------------! - cpatch => csite%patch(ipa) - - ipft = cpatch%pft(ico) - !---------------------------------------------------------------------------------------! - ! Here we decide how to compute the mean available water fraction. ! - !---------------------------------------------------------------------------------------! - if (spot_phen) then - !----- Use soil potential to determine phenology. -----------------------------------! - cpatch%paw_avg(ico) = 0.0 - do k=cpatch%krdepth(ico),mzg - nsoil = ntext_soil(k) - - psi_layer = soil(nsoil)%slpots & - / (csite%soil_water(k,ipa) / soil(nsoil)%slmsts) ** soil(nsoil)%slbs - psi_wilt = soil(nsoil)%slpots & - / (soil(nsoil)%soilwp / soil(nsoil)%slmsts) ** soil(nsoil)%slbs - psi_crit = soil(nsoil)%slpots & - / (soil(nsoil)%soilld / soil(nsoil)%slmsts) ** soil(nsoil)%slbs - - cpatch%paw_avg(ico) = cpatch%paw_avg(ico) & - + max(0.0, (psi_layer - psi_wilt)) & - * dslz(k) / (psi_crit - psi_wilt) - end do - cpatch%paw_avg(ico) = - cpatch%paw_avg(ico) / slz(cpatch%krdepth(ico)) - else - !----- Use soil moisture (mass) to determine phenology. -----------------------------! - cpatch%paw_avg(ico) = 0.0 - do k = cpatch%krdepth(ico), mzg - nsoil = ntext_soil(k) - cpatch%paw_avg(ico) = cpatch%paw_avg(ico) & - + max(0.0, (csite%soil_water(k,ipa) - soil(nsoil)%soilwp)) & - * dslz(k) / (soil(nsoil)%soilld - soil(nsoil)%soilwp) - end do - cpatch%paw_avg(ico) = - cpatch%paw_avg(ico) / slz(cpatch%krdepth(ico)) - end if - !---------------------------------------------------------------------------------------! - ! We make the elongation factor 1.0 when we are not solving the vegetation dynamics, ! - ! otherwise we assign the normal values. ! - !---------------------------------------------------------------------------------------! - select case (ivegt_dynamics) - case (0) - cpatch%elongf(ico) = 1.0 + !------------------------------------------------------------------------------------! + ! Here we decide how to compute the mean available water fraction. ! + !------------------------------------------------------------------------------------! + if (spot_phen) then + !----- Use soil potential to determine phenology. --------------------------------! + paw_avg = 0.0 + do k=kroot,mzg + nsoil = ntext_soil(k) + mcheight = 0.5 * ( height + h2crownbh(height,ipft) ) + + psi_layer = slzt(k) - mcheight & + + soil(nsoil)%slpots & + / (soil_water(k) / soil(nsoil)%slmsts) ** soil(nsoil)%slbs + psi_wilt = soil(nsoil)%slpots & + / (soil(nsoil)%soilwp / soil(nsoil)%slmsts) ** soil(nsoil)%slbs + psi_crit = soil(nsoil)%slpots & + / (soil(nsoil)%soilld / soil(nsoil)%slmsts) ** soil(nsoil)%slbs + + paw_avg = paw_avg + max(0.0, (psi_layer - psi_wilt)) * dslz(k) & + / (psi_crit - psi_wilt) + end do + paw_avg = paw_avg / abs(slz(kroot)) + else + !----- Use soil moisture (mass) to determine phenology. --------------------------! + paw_avg = 0.0 + do k = kroot, mzg + nsoil = ntext_soil(k) + paw_avg = paw_avg + max(0.0, (soil_water(k) - soil(nsoil)%soilwp)) * dslz(k) & + / (soil(nsoil)%soilld - soil(nsoil)%soilwp) + end do + paw_avg = paw_avg / abs(slz(kroot)) + end if - case default + !------------------------------------------------------------------------------------! + ! Find the elongation factor according to the phenology of this PFT. ! + !------------------------------------------------------------------------------------! select case (phenology(ipft)) case (1) - if (cpatch%paw_avg(ico) < 1.0) then - cpatch%elongf(ico) = 0.0 + if (paw_avg < 1.0) then + elongf = 0.0 else - cpatch%elongf(ico) = 1.0 + elongf = 1.0 end if case (3,4) - cpatch%elongf(ico) = max(0.0,min(1.0,cpatch%paw_avg(ico))) + elongf = max(0.0,min(1.0,paw_avg)) case default - cpatch%elongf(ico) = 1.0 + elongf = 1.0 end select + !------------------------------------------------------------------------------------! - end select - !---------------------------------------------------------------------------------------! - - !----- Set phenology status according to the elongation factor. ------------------------! - if (cpatch%elongf(ico) >= 1.0) then - cpatch%phenology_status(ico) = 0 - elseif (cpatch%elongf(ico) > elongf_min) then - cpatch%phenology_status(ico) = -1 - else - cpatch%phenology_status(ico) = 2 - cpatch%elongf(ico) = 0. - end if - !---------------------------------------------------------------------------------------! - + !----- Set phenology status according to the elongation factor. ---------------------! + if (elongf >= 1.0) then + phenology_status = 0 + elseif (elongf > elongf_min) then + phenology_status = -1 + else + phenology_status = 2 + elongf = 0. + end if + !------------------------------------------------------------------------------------! - !----- Compute the biomass of living tissues. ------------------------------------------! - salloc = 1.0 + q(ipft) + qsw(ipft) * cpatch%hite(ico) - salloci = 1.0 / salloc - bleaf_max = dbh2bl(cpatch%dbh(ico),cpatch%pft(ico)) - balive_max = bleaf_max * salloc - select case (cpatch%phenology_status(ico)) - case (2) - cpatch%bleaf(ico) = 0. - cpatch%elongf(ico) = 0. - case default - cpatch%bleaf(ico) = bleaf_max * cpatch%elongf(ico) - end select - cpatch%broot(ico) = balive_max * q(ipft) * salloci - cpatch%bsapwood(ico) = balive_max * qsw(ipft) * cpatch%hite(ico) * salloci - cpatch%balive(ico) = cpatch%bleaf(ico) + cpatch%broot(ico) + cpatch%bsapwood(ico) - !---------------------------------------------------------------------------------------! + !----- Compute the biomass of living tissues. ---------------------------------------! + salloc = 1.0 + q(ipft) + qsw(ipft) * height + salloci = 1.0 / salloc + bleaf_max = dbh2bl(dbh,ipft) + balive_max = bleaf_max * salloc + bleaf = bleaf_max * elongf + broot = balive_max * q(ipft) * salloci + bsapwood = balive_max * qsw(ipft) * height * salloci + balive = bleaf + broot + bsapwood + !------------------------------------------------------------------------------------! - !---------------------------------------------------------------------------------------! - ! Here we account for part of the carbon that didn't go to the leaves. At this ! - ! point we will be nice to the plants and leave all the carbon that didn't go to ! - ! leaves in the storage. This gives some extra chance for the plant whilst it ! - ! conserves the total carbon. ! - !---------------------------------------------------------------------------------------! - cpatch%bstorage(ico) = max(0.0, bleaf_max - cpatch%bleaf(ico)) - !---------------------------------------------------------------------------------------! - return -end subroutine pheninit_balive_bstorage -!==========================================================================================! -!==========================================================================================! + !------------------------------------------------------------------------------------! + ! Here we account for part of the carbon that didn't go to the leaves. At this ! + ! point we will be nice to the plants and leave all the carbon that didn't go to ! + ! leaves in the storage. This gives some extra chance for the plant whilst it ! + ! conserves the total carbon. ! + !------------------------------------------------------------------------------------! + bstorage = max(0.0, bleaf_max - bleaf) + !------------------------------------------------------------------------------------! + return + end subroutine pheninit_balive_bstorage + !=======================================================================================! + !=======================================================================================! -!==========================================================================================! -!==========================================================================================! -! This function computes the length of daylight for a given latitude and day of year. ! -! The result is given in minutes. ! -!------------------------------------------------------------------------------------------! -real function daylength(lat,doy) - use consts_coms , only : pio180 & ! intent(in) - , twopi ! ! intent(in) - implicit none - !----- Arguments -----------------------------------------------------------------------! - real , intent(in) :: lat - integer , intent(in) :: doy - !----- Local variables -----------------------------------------------------------------! - real :: arg + !=======================================================================================! + !=======================================================================================! + ! This function computes the length of daylight for a given latitude and day of ! + ! year. The result is given in minutes. ! !---------------------------------------------------------------------------------------! + real function daylength(lat,doy) + + use consts_coms , only : pio180 & ! intent(in) + , twopi ! ! intent(in) + implicit none + !----- Arguments --------------------------------------------------------------------! + real , intent(in) :: lat + integer , intent(in) :: doy + !----- Local variables --------------------------------------------------------------! + real :: arg + !------------------------------------------------------------------------------------! - arg = -tan(lat * pio180) * tan(-23.5 * pio180 * cos(twopi/365.0 * (float(doy)+9.0))) + arg = -tan(lat * pio180) * tan(-23.5 * pio180 * cos(twopi/365.0 * (float(doy)+9.0))) - if (arg >= 1.0) then - daylength = 0.0 - elseif (arg <= 1.0) then - daylength = 1440.0 - else ! if (abs(arg) < 1.0) then - daylength = 120.0 * acos(arg) / (15.0 * pio180) - end if + if (arg >= 1.0) then + daylength = 0.0 + elseif (arg <= 1.0) then + daylength = 1440.0 + else ! if (abs(arg) < 1.0) then + daylength = 120.0 * acos(arg) / (15.0 * pio180) + end if - return -end function daylength + return + end function daylength + !=======================================================================================! + !=======================================================================================! +end module phenology_aux !==========================================================================================! !==========================================================================================! diff --git a/ED/src/dynamics/phenology_driv.f90 b/ED/src/dynamics/phenology_driv.f90 index bd74a7dc0..f6d26673d 100644 --- a/ED/src/dynamics/phenology_driv.f90 +++ b/ED/src/dynamics/phenology_driv.f90 @@ -3,11 +3,14 @@ ! This subroutine controls the changes in leaf biomass due to phenology. ! !------------------------------------------------------------------------------------------! subroutine phenology_driver(cgrid, doy, month, tfact) - use ed_state_vars , only : edtype & ! structure - , polygontype & ! structure - , sitetype ! ! structure - use phenology_coms , only : iphen_scheme ! ! intent(in) - use ed_misc_coms , only : current_time ! ! intent(in) + use ed_state_vars , only : edtype & ! structure + , polygontype & ! structure + , sitetype ! ! structure + use phenology_coms , only : iphen_scheme ! ! intent(in) + use ed_misc_coms , only : current_time ! ! intent(in) + use phenology_aux , only : prescribed_leaf_state & ! subroutine + , update_thermal_sums & ! subroutine + , update_turnover ! ! subroutine implicit none !----- Arguments -----------------------------------------------------------------------! type(edtype) , target :: cgrid @@ -79,11 +82,14 @@ end subroutine phenology_driver ! ecosystem state. ! !------------------------------------------------------------------------------------------! subroutine phenology_driver_eq_0(cgrid, doy, month, tfact) - use ed_state_vars , only : edtype & ! structure - , polygontype & ! structure - , sitetype ! ! structure - use phenology_coms , only : iphen_scheme ! ! intent(in) - use ed_misc_coms , only : current_time ! ! intent(in) + use ed_state_vars , only : edtype & ! structure + , polygontype & ! structure + , sitetype ! ! structure + use phenology_coms , only : iphen_scheme ! ! intent(in) + use ed_misc_coms , only : current_time ! ! intent(in) + use phenology_aux , only : prescribed_leaf_state & ! subroutine + , update_thermal_sums & ! subroutine + , update_turnover ! ! subroutine implicit none !----- Arguments -----------------------------------------------------------------------! type(edtype) , target :: cgrid @@ -178,7 +184,7 @@ subroutine update_phenology(doy, cpoly, isi, lat) use allometry , only : area_indices & ! subroutine , ed_biomass & ! function , dbh2bl ! ! function - + use phenology_aux , only : daylength ! ! function implicit none !----- Arguments -----------------------------------------------------------------------! type(polygontype) , target :: cpoly @@ -202,8 +208,6 @@ subroutine update_phenology(doy, cpoly, isi, lat) real :: old_leaf_hcap real :: old_wood_hcap real :: salloci - !----- External functions. -------------------------------------------------------------! - real , external :: daylength !----- Variables used only for debugging purposes. -------------------------------------! logical , parameter :: printphen=.false. logical, dimension(n_pft), save :: first_time=.true. @@ -486,12 +490,11 @@ subroutine update_phenology(doy, cpoly, isi, lat) end select !---------------------------------------------------------------------------------! - !----- Update LAI, WPA, and WAI accordingly. -------------------------------------! + !----- Update LAI, WAI, and CAI accordingly. -------------------------------------! call area_indices(cpatch%nplant(ico),cpatch%bleaf(ico),cpatch%bdead(ico) & ,cpatch%balive(ico),cpatch%dbh(ico),cpatch%hite(ico) & ,cpatch%pft(ico),cpatch%sla(ico),cpatch%lai(ico) & - ,cpatch%wpa(ico),cpatch%wai(ico),cpatch%crown_area(ico) & - ,cpatch%bsapwood(ico)) + ,cpatch%wai(ico),cpatch%crown_area(ico),cpatch%bsapwood(ico)) !----- Update above-ground biomass. ----------------------------------------------! cpatch%agb(ico) = ed_biomass(cpatch%bdead(ico),cpatch%balive(ico) & @@ -563,6 +566,7 @@ subroutine update_phenology_eq_0(doy, cpoly, isi, lat) use allometry , only : area_indices & ! subroutine , ed_biomass & ! function , dbh2bl ! ! function + use phenology_aux , only : daylength ! ! function implicit none !----- Arguments -----------------------------------------------------------------------! @@ -587,8 +591,6 @@ subroutine update_phenology_eq_0(doy, cpoly, isi, lat) real :: old_leaf_hcap real :: old_wood_hcap real :: salloci - !----- External functions. -------------------------------------------------------------! - real , external :: daylength !---------------------------------------------------------------------------------------! @@ -827,12 +829,11 @@ subroutine update_phenology_eq_0(doy, cpoly, isi, lat) end select !---------------------------------------------------------------------------------! - !----- Update LAI, WPA, and WAI accordingly. -------------------------------------! + !----- Update LAI, WAI, and CAI accordingly. -------------------------------------! call area_indices(cpatch%nplant(ico),cpatch%bleaf(ico),cpatch%bdead(ico) & ,cpatch%balive(ico),cpatch%dbh(ico),cpatch%hite(ico) & ,cpatch%pft(ico),cpatch%sla(ico),cpatch%lai(ico) & - ,cpatch%wpa(ico),cpatch%wai(ico),cpatch%crown_area(ico) & - ,cpatch%bsapwood(ico)) + ,cpatch%wai(ico),cpatch%crown_area(ico),cpatch%bsapwood(ico)) !----- Update above-ground biomass. ----------------------------------------------! cpatch%agb(ico) = ed_biomass(cpatch%bdead(ico),cpatch%balive(ico) & diff --git a/ED/src/dynamics/photosyn_driv.f90 b/ED/src/dynamics/photosyn_driv.f90 index bb99692a7..ffc19eb11 100644 --- a/ED/src/dynamics/photosyn_driv.f90 +++ b/ED/src/dynamics/photosyn_driv.f90 @@ -97,11 +97,9 @@ subroutine canopy_photosynthesis(csite,cmet,mzg,ipa,lsl,ntext_soil !----- Find the patch-level Total Leaf and Wood Area Index. ----------------------------! csite%lai(ipa) = 0.0 - csite%wpa(ipa) = 0.0 csite%wai(ipa) = 0.0 do ico=1,cpatch%ncohorts csite%lai(ipa) = csite%lai(ipa) + cpatch%lai(ico) - csite%wpa(ipa) = csite%wpa(ipa) + cpatch%wpa(ico) csite%wai(ipa) = csite%wai(ipa) + cpatch%wai(ico) end do !---------------------------------------------------------------------------------------! @@ -337,7 +335,6 @@ subroutine canopy_photosynthesis(csite,cmet,mzg,ipa,lsl,ntext_soil , vm & ! Max. capacity of Rubisco [µmol/m²/s] , compp & ! Gross photo. compensation point [ µmol/mol] , limit_flag & ! Photosynthesis limitation flag [ ---] - , csite%old_stoma_data_max(ipft,ipa) & ! Previous state [ ---] ) end if end do @@ -418,7 +415,6 @@ subroutine canopy_photosynthesis(csite,cmet,mzg,ipa,lsl,ntext_soil , vm & ! Max. capacity of Rubisco [µmol/m²/s] , compp & ! Gross photo. compensation point [ µmol/mol] , limit_flag & ! Photosynthesis limitation flag [ ---] - , csite%old_stoma_data_max(ipft,ipa) & ! Previous state [ ---] ) !----- Convert leaf respiration to [µmol/m²ground/s] --------------------------! @@ -452,7 +448,7 @@ subroutine canopy_photosynthesis(csite,cmet,mzg,ipa,lsl,ntext_soil cpatch%fsw(ico) = 1.0 case (1,2) - water_demand = cpatch%psi_open(ico) + water_demand = cpatch%psi_open(ico) * cpatch%lai(ico) if (cpatch%water_supply (ico) < tiny_num) then cpatch%fsw(ico) = 0.0 else @@ -661,6 +657,8 @@ subroutine print_photo_details(cmet,csite,ipa,ico,limit_flag,vm,compp) else par_area = 0.0 parv = 0.0 + nir_area = 0.0 + nirv = 0.0 util_parv = 0.0 end if diff --git a/ED/src/dynamics/radiate_driver.f90 b/ED/src/dynamics/radiate_driver.f90 index d0e1b8c28..35c01e917 100644 --- a/ED/src/dynamics/radiate_driver.f90 +++ b/ED/src/dynamics/radiate_driver.f90 @@ -200,7 +200,8 @@ subroutine sfcrad_ed(cosz,cosaoi,csite,mzg,mzs,ntext_soil,ncol_soil,maxcohort,tu use ed_state_vars , only : sitetype & ! structure , patchtype ! ! structure - use canopy_layer_coms , only : crown_mod ! ! intent(in) + use canopy_layer_coms , only : crown_mod & ! intent(in) + , tai_lyr_max ! ! intent(in) use canopy_radiation_coms, only : icanrad & ! intent(in) , cosz_min & ! intent(in) , clumping_factor & ! intent(in) @@ -220,6 +221,7 @@ subroutine sfcrad_ed(cosz,cosaoi,csite,mzg,mzs,ntext_soil,ncol_soil,maxcohort,tu use consts_coms , only : stefan ! ! intent(in) use ed_max_dims , only : n_pft ! ! intent(in) use allometry , only : h2crownbh ! ! intent(in) + use ed_misc_coms , only : ibigleaf ! ! intent(in) implicit none !----- Arguments. ----------------------------------------------------------------------! @@ -238,84 +240,147 @@ subroutine sfcrad_ed(cosz,cosaoi,csite,mzg,mzs,ntext_soil,ncol_soil,maxcohort,tu logical , intent(in) :: twilight integer , intent(out) :: tuco !----- Local variables. ----------------------------------------------------------------! - type(patchtype) , pointer :: cpatch - integer , dimension(maxcohort) :: pft_array - integer :: il - integer :: ipa - integer :: ico - integer :: ipft - integer :: cohort_count - integer :: nsoil - integer :: colour - integer :: k - integer :: ksn - real :: fcpct - real :: albedo_soil_par - real :: albedo_soil_nir - real :: albedo_sfcw_par - real :: albedo_sfcw_nir - real :: rad_par - real :: rad_nir - real :: fractrans_par - real :: fractrans_nir - real , dimension(mzs) :: fracabs_par - real , dimension(mzs) :: fracabs_nir - real :: abs_ground_par - real :: abs_ground_nir - real :: albedo_ground_par - real :: albedo_ground_nir - real :: downward_par_below_beam - real :: upward_par_above_beam - real :: downward_nir_below_beam - real :: upward_nir_above_beam - real(kind=8) , dimension(maxcohort) :: leaf_temp_array - real(kind=8) , dimension(maxcohort) :: wood_temp_array - real(kind=8) , dimension(maxcohort) :: lai_array - real(kind=8) , dimension(maxcohort) :: wai_array - real(kind=8) , dimension(maxcohort) :: CA_array - real(kind=8) , dimension(maxcohort) :: htop_array - real(kind=8) , dimension(maxcohort) :: hbot_array - real(kind=8) , dimension(maxcohort) :: lambda_array - real(kind=8) , dimension(maxcohort) :: beam_level_array - real(kind=8) , dimension(maxcohort) :: diff_level_array - real(kind=8) , dimension(maxcohort) :: light_level_array - real(kind=8) , dimension(maxcohort) :: light_beam_level_array - real(kind=8) , dimension(maxcohort) :: light_diff_level_array - real , dimension(maxcohort) :: par_v_beam_array - real , dimension(maxcohort) :: rshort_v_beam_array - real , dimension(maxcohort) :: par_v_diffuse_array - real , dimension(maxcohort) :: rshort_v_diffuse_array - real , dimension(maxcohort) :: lw_v_surf_array - real , dimension(maxcohort) :: lw_v_incid_array - real :: downward_par_below_diffuse - real :: upward_par_above_diffuse - real :: downward_nir_below_diffuse - real :: upward_nir_above_diffuse - real(kind=8) :: lambda_tot - real :: T_surface - real :: emissivity - real :: downward_lw_below_surf - real :: downward_lw_below_incid - real :: upward_lw_below_surf - real :: upward_lw_below_incid - real :: upward_lw_above_surf - real :: upward_lw_above_incid - real :: downward_rshort_below_beam - real :: downward_rshort_below_diffuse - real :: surface_absorbed_longwave_surf - real :: surface_absorbed_longwave_incid - real :: nir_v_beam - real :: nir_v_diffuse - real :: wleaf_vis - real :: wleaf_nir - real :: wleaf_tir - real :: wwood_vis - real :: wwood_nir - real :: wwood_tir + type(patchtype) , pointer :: cpatch + integer , dimension(:) , allocatable :: pft_array + integer :: il + integer :: ipa + integer :: ico + integer :: ipft + integer :: cohort_count + integer :: max_cohort_count + integer :: nsoil + integer :: colour + integer :: k + integer :: ksn + real :: fcpct + real :: albedo_soil_par + real :: albedo_soil_nir + real :: albedo_sfcw_par + real :: albedo_sfcw_nir + real :: rad_par + real :: rad_nir + real :: fractrans_par + real :: fractrans_nir + real , dimension(mzs) :: fracabs_par + real , dimension(mzs) :: fracabs_nir + real :: abs_ground_par + real :: abs_ground_nir + real :: albedo_ground_par + real :: albedo_ground_nir + real :: downward_par_below_beam + real :: upward_par_above_beam + real :: downward_nir_below_beam + real :: upward_nir_above_beam + real(kind=8) , dimension(:) , allocatable :: leaf_temp_array + real(kind=8) , dimension(:) , allocatable :: wood_temp_array + real(kind=8) , dimension(:) , allocatable :: lai_array + real(kind=8) , dimension(:) , allocatable :: wai_array + real(kind=8) , dimension(:) , allocatable :: CA_array + real(kind=8) , dimension(:) , allocatable :: htop_array + real(kind=8) , dimension(:) , allocatable :: hbot_array + real(kind=8) , dimension(:) , allocatable :: lambda_array + real(kind=8) , dimension(:) , allocatable :: beam_level_array + real(kind=8) , dimension(:) , allocatable :: diff_level_array + real(kind=8) , dimension(:) , allocatable :: light_level_array + real(kind=8) , dimension(:) , allocatable :: light_beam_level_array + real(kind=8) , dimension(:) , allocatable :: light_diff_level_array + real , dimension(:) , allocatable :: par_v_beam_array + real , dimension(:) , allocatable :: rshort_v_beam_array + real , dimension(:) , allocatable :: par_v_diffuse_array + real , dimension(:) , allocatable :: rshort_v_diffuse_array + real , dimension(:) , allocatable :: lw_v_surf_array + real , dimension(:) , allocatable :: lw_v_incid_array + real :: downward_par_below_diffuse + real :: upward_par_above_diffuse + real :: downward_nir_below_diffuse + real :: upward_nir_above_diffuse + real(kind=8) :: lambda_tot + real :: T_surface + real :: emissivity + real :: downward_lw_below_surf + real :: downward_lw_below_incid + real :: upward_lw_below_surf + real :: upward_lw_below_incid + real :: upward_lw_above_surf + real :: upward_lw_above_incid + real :: downward_rshort_below_beam + real :: downward_rshort_below_diffuse + real :: surface_absorbed_longwave_surf + real :: surface_absorbed_longwave_incid + real :: nir_v_beam + real :: nir_v_diffuse + real :: wleaf_vis + real :: wleaf_nir + real :: wleaf_tir + real :: wwood_vis + real :: wwood_nir + real :: wwood_tir + real :: bl_lai_each + real :: bl_wai_each !----- External function. --------------------------------------------------------------! - real , external :: sngloff + real , external :: sngloff !----- Local constants. ----------------------------------------------------------------! - real(kind=8) , parameter :: tiny_offset = 1.d-20 + real(kind=8) , parameter :: tiny_offset = 1.d-20 + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! Allocate arrays based on the type of vegetation structure we are solving. ! + !---------------------------------------------------------------------------------------! + select case (ibigleaf) + case (0) + !---- Size and age structure. Use the maximum number of cohorts. -------------------! + allocate (pft_array (maxcohort)) + allocate (leaf_temp_array (maxcohort)) + allocate (wood_temp_array (maxcohort)) + allocate (lai_array (maxcohort)) + allocate (wai_array (maxcohort)) + allocate (CA_array (maxcohort)) + allocate (htop_array (maxcohort)) + allocate (hbot_array (maxcohort)) + allocate (lambda_array (maxcohort)) + allocate (beam_level_array (maxcohort)) + allocate (diff_level_array (maxcohort)) + allocate (light_level_array (maxcohort)) + allocate (light_beam_level_array (maxcohort)) + allocate (light_diff_level_array (maxcohort)) + allocate (par_v_beam_array (maxcohort)) + allocate (rshort_v_beam_array (maxcohort)) + allocate (par_v_diffuse_array (maxcohort)) + allocate (rshort_v_diffuse_array (maxcohort)) + allocate (lw_v_surf_array (maxcohort)) + allocate (lw_v_incid_array (maxcohort)) + case (1) + !---- Big leaf. Use the maximum LAI. -----------------------------------------------! + max_cohort_count=0 + do ipa = 1,csite%npatches + cpatch => csite%patch(ipa) + cohort_count = ceiling( (cpatch%lai(1) + cpatch%wai(1)) / tai_lyr_max ) + max_cohort_count=max(max_cohort_count, cohort_count) + end do + + allocate (pft_array (max_cohort_count)) + allocate (leaf_temp_array (max_cohort_count)) + allocate (wood_temp_array (max_cohort_count)) + allocate (lai_array (max_cohort_count)) + allocate (wai_array (max_cohort_count)) + allocate (CA_array (max_cohort_count)) + allocate (htop_array (max_cohort_count)) + allocate (hbot_array (max_cohort_count)) + allocate (lambda_array (max_cohort_count)) + allocate (beam_level_array (max_cohort_count)) + allocate (diff_level_array (max_cohort_count)) + allocate (light_level_array (max_cohort_count)) + allocate (light_beam_level_array (max_cohort_count)) + allocate (light_diff_level_array (max_cohort_count)) + allocate (par_v_beam_array (max_cohort_count)) + allocate (rshort_v_beam_array (max_cohort_count)) + allocate (par_v_diffuse_array (max_cohort_count)) + allocate (rshort_v_diffuse_array (max_cohort_count)) + allocate (lw_v_surf_array (max_cohort_count)) + allocate (lw_v_incid_array (max_cohort_count)) + end select !---------------------------------------------------------------------------------------! @@ -334,14 +399,7 @@ subroutine sfcrad_ed(cosz,cosaoi,csite,mzg,mzs,ntext_soil,ncol_soil,maxcohort,tu - !----- Recalc the maximum photosynthetic rates next time around. --------------------! - csite%old_stoma_data_max(1:n_pft,ipa)%recalc = 1 - !------------------------------------------------------------------------------------! - - - !----- Set the light extinction to zero, just in case it is night time... -----------! - csite%lambda_light(ipa) = 0.0 lambda_tot = 0.d0 !------------------------------------------------------------------------------------! @@ -357,95 +415,175 @@ subroutine sfcrad_ed(cosz,cosaoi,csite,mzg,mzs,ntext_soil,ncol_soil,maxcohort,tu !------------------------------------------------------------------------------------! - !------------------------------------------------------------------------------------! - ! Loop over cohorts. Unusually, we here start at the shortest. Required by ! - ! radiation schemes. ! + ! Transfer information from linked lists to arrays. Here we must check ! + ! whether is running as a true size-and-age structure model, or as big leaf. ! !------------------------------------------------------------------------------------! - do ico = cpatch%ncohorts,1,-1 - - !----- Initialize values. --------------------------------------------------------! - cpatch%par_l(ico) = 0.0 - cpatch%par_l_beam(ico) = 0.0 - cpatch%par_l_diffuse(ico) = 0.0 - - cpatch%rshort_l(ico) = 0.0 - cpatch%rshort_l_beam(ico) = 0.0 - cpatch%rshort_l_diffuse(ico) = 0.0 - - cpatch%rlong_l(ico) = 0.0 - cpatch%rlong_l_incid(ico) = 0.0 - cpatch%rlong_l_surf(ico) = 0.0 - - cpatch%rshort_w(ico) = 0.0 - cpatch%rshort_w_beam(ico) = 0.0 - cpatch%rshort_w_diffuse(ico) = 0.0 - - cpatch%rlong_w(ico) = 0.0 - cpatch%rlong_w_incid(ico) = 0.0 - cpatch%rlong_w_surf(ico) = 0.0 + select case (ibigleaf) + case (0) - cpatch%old_stoma_data(ico)%recalc = 1 - - cpatch%light_level (ico) = 0.0 - cpatch%light_level_beam(ico) = 0.0 - cpatch%light_level_diff(ico) = 0.0 - cpatch%lambda_light (ico) = 0.0 - cpatch%beamext_level (ico) = 0.0 - cpatch%diffext_level (ico) = 0.0 - - !------ Transfer information from linked lists to arrays. ------------------------! - - if (cpatch%leaf_resolvable(ico) .or. cpatch%wood_resolvable(ico)) then - !----- This will eventually have the index of the tallest used cohort. --------! - tuco = ico + !---------------------------------------------------------------------------------! + ! Size- and age-structure. Each layer in the radiation will correspond to ! + ! one cohort. Unusually, here we go from shortest to tallest, as required by the ! + ! radiation schemes. ! + !---------------------------------------------------------------------------------! + do ico = cpatch%ncohorts,1,-1 + + !----- Initialize values. -----------------------------------------------------! + cpatch%par_l(ico) = 0.0 + cpatch%par_l_beam(ico) = 0.0 + cpatch%par_l_diffuse(ico) = 0.0 + + cpatch%rshort_l(ico) = 0.0 + cpatch%rshort_l_beam(ico) = 0.0 + cpatch%rshort_l_diffuse(ico) = 0.0 + + cpatch%rlong_l(ico) = 0.0 + cpatch%rlong_l_incid(ico) = 0.0 + cpatch%rlong_l_surf(ico) = 0.0 + + cpatch%rshort_w(ico) = 0.0 + cpatch%rshort_w_beam(ico) = 0.0 + cpatch%rshort_w_diffuse(ico) = 0.0 + + cpatch%rlong_w(ico) = 0.0 + cpatch%rlong_w_incid(ico) = 0.0 + cpatch%rlong_w_surf(ico) = 0.0 - cohort_count = cohort_count + 1 - pft_array (cohort_count) = cpatch%pft(ico) - !------------------------------------------------------------------------------! - ! Here we only tell the true LAI if the leaf is resolvable, and the true ! - ! WAI if the wood is resolvable. ! - !------------------------------------------------------------------------------! - if (cpatch%leaf_resolvable(ico)) then - lai_array (cohort_count) = dble(cpatch%lai(ico)) - else - lai_array (cohort_count) = 0.d0 - end if - if (cpatch%wood_resolvable(ico)) then - wai_array (cohort_count) = dble(cpatch%wai(ico)) - else - wai_array (cohort_count) = 0.d0 + cpatch%light_level (ico) = 0.0 + cpatch%light_level_beam(ico) = 0.0 + cpatch%light_level_diff(ico) = 0.0 + if (cpatch%leaf_resolvable(ico) .or. cpatch%wood_resolvable(ico)) then + !----- This will eventually have the index of the tallest used cohort. -----! + tuco = ico + + cohort_count = cohort_count + 1 + pft_array (cohort_count) = cpatch%pft(ico) + !---------------------------------------------------------------------------! + ! Here we only tell the true LAI if the leaf is resolvable, and the ! + ! true WAI if the wood is resolvable. ! + !---------------------------------------------------------------------------! + if (cpatch%leaf_resolvable(ico)) then + lai_array (cohort_count) = dble(cpatch%lai(ico)) + else + lai_array (cohort_count) = 0.d0 + end if + if (cpatch%wood_resolvable(ico)) then + wai_array (cohort_count) = dble(cpatch%wai(ico)) + else + wai_array (cohort_count) = 0.d0 + end if + !---------------------------------------------------------------------------! + + leaf_temp_array (cohort_count) = dble(cpatch%leaf_temp(ico)) + wood_temp_array (cohort_count) = dble(cpatch%wood_temp(ico)) + rshort_v_beam_array (cohort_count) = 0.0 + par_v_beam_array (cohort_count) = 0.0 + rshort_v_diffuse_array (cohort_count) = 0.0 + par_v_diffuse_array (cohort_count) = 0.0 + lambda_array (cohort_count) = 0.d0 + beam_level_array (cohort_count) = 0.d0 + diff_level_array (cohort_count) = 0.d0 + light_level_array (cohort_count) = 0.d0 + light_beam_level_array (cohort_count) = 0.d0 + light_diff_level_array (cohort_count) = 0.d0 + + !---------------------------------------------------------------------------! + ! Decide whether to assume infinite crown, or the crown area allometry ! + ! method as in Dietze and Clark (2008). ! + !---------------------------------------------------------------------------! + select case (crown_mod) + case (0) + CA_array (cohort_count) = 1.d0 + case (1) + CA_array (cohort_count) = dble(cpatch%crown_area(ico)) + end select + !---------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------! + end do + !---------------------------------------------------------------------------------! + case (1) + !---------------------------------------------------------------------------------! + ! Big-leaf solver. We have either 0 (desert) or 1 cohort. In case of zero, ! + ! we bypass the entire cohort loop, otherwise we check how many layers we will ! + ! create. ! + !---------------------------------------------------------------------------------! + if (cpatch%ncohorts > 0) then + !----- Initialize values. -----------------------------------------------------! + cpatch%par_l(1) = 0.0 + cpatch%par_l_beam(1) = 0.0 + cpatch%par_l_diffuse(1) = 0.0 + + cpatch%rshort_l(1) = 0.0 + cpatch%rshort_l_beam(1) = 0.0 + cpatch%rshort_l_diffuse(1) = 0.0 + + cpatch%rlong_l(1) = 0.0 + cpatch%rlong_l_incid(1) = 0.0 + cpatch%rlong_l_surf(1) = 0.0 + + cpatch%rshort_w(1) = 0.0 + cpatch%rshort_w_beam(1) = 0.0 + cpatch%rshort_w_diffuse(1) = 0.0 + + cpatch%rlong_w(1) = 0.0 + cpatch%rlong_w_incid(1) = 0.0 + cpatch%rlong_w_surf(1) = 0.0 + + cpatch%light_level (1) = 0.0 + cpatch%light_level_beam(1) = 0.0 + cpatch%light_level_diff(1) = 0.0 - leaf_temp_array (cohort_count) = dble(cpatch%leaf_temp(ico)) - wood_temp_array (cohort_count) = dble(cpatch%wood_temp(ico)) - rshort_v_beam_array (cohort_count) = 0.0 - par_v_beam_array (cohort_count) = 0.0 - rshort_v_diffuse_array (cohort_count) = 0.0 - par_v_diffuse_array (cohort_count) = 0.0 - lambda_array (cohort_count) = 0.d0 - beam_level_array (cohort_count) = 0.d0 - diff_level_array (cohort_count) = 0.d0 - light_level_array (cohort_count) = 0.d0 - light_beam_level_array (cohort_count) = 0.d0 - light_diff_level_array (cohort_count) = 0.d0 - htop_array (cohort_count) = dble(cpatch%hite(ico)) - hbot_array (cohort_count) = dble(h2crownbh(cpatch%hite(ico) & - ,cpatch%pft(ico) ) ) !------------------------------------------------------------------------------! - ! Decide whether to assume infinite crown, or the crown area allometry ! - ! method as in Dietze and Clark (2008). ! + ! Check whether the cohort is resolvable or not. ! !------------------------------------------------------------------------------! - select case (crown_mod) - case (0) - CA_array (cohort_count) = 1.d0 - case (1) - CA_array (cohort_count) = dble(cpatch%crown_area(ico)) - end select + if (cpatch%leaf_resolvable(1) .or. cpatch%wood_resolvable(1)) then + tuco = 1 !---- Dummy variable. ---------------------------------------------! + + !---------------------------------------------------------------------------! + ! Patch/cohort has enough leaf or wood. Find the number of layers for ! + ! the radiation scheme. ! + !---------------------------------------------------------------------------! + cohort_count = ceiling( (cpatch%lai(1) + cpatch%wai(1)) / tai_lyr_max ) + bl_lai_each = cpatch%lai(1) / real(cohort_count) + bl_wai_each = cpatch%wai(1) / real(cohort_count) + !---------------------------------------------------------------------------! + + !---------------------------------------------------------------------------! + ! Loop over all layers, and assign equal amounts of LAI and WAI such ! + ! that they add back to the total amount. We impose crown model off for ! + ! big leaf, so CA_array must be always set to 1. ! + !---------------------------------------------------------------------------! + do ico = 1, cohort_count + pft_array (ico) = cpatch%pft(1) + lai_array (ico) = dble(bl_lai_each) + wai_array (ico) = dble(bl_wai_each) + CA_array (ico) = 1.d0 + leaf_temp_array (ico) = dble(cpatch%leaf_temp(1)) + wood_temp_array (ico) = dble(cpatch%wood_temp(1)) + rshort_v_beam_array (ico) = 0.0 + par_v_beam_array (ico) = 0.0 + rshort_v_diffuse_array (ico) = 0.0 + par_v_diffuse_array (ico) = 0.0 + lambda_array (ico) = 0.d0 + beam_level_array (ico) = 0.d0 + diff_level_array (ico) = 0.d0 + light_level_array (ico) = 0.d0 + light_beam_level_array (ico) = 0.d0 + light_diff_level_array (ico) = 0.d0 + end do + !---------------------------------------------------------------------------! + end if !------------------------------------------------------------------------------! end if + !---------------------------------------------------------------------------------! + end select + !------------------------------------------------------------------------------------! - end do + + + !------------------------------------------------------------------------------------! csite%rshort_s_diffuse(:,ipa) = 0.0 csite%rshort_s_beam (:,ipa) = 0.0 !------------------------------------------------------------------------------------! @@ -796,7 +934,6 @@ subroutine sfcrad_ed(cosz,cosaoi,csite,mzg,mzs,ntext_soil,ncol_soil,maxcohort,tu , tiny_offset ) csite%albedo(ipa) = ( upward_par_above_beam + upward_nir_above_beam & + upward_par_above_diffuse + upward_nir_above_diffuse ) - csite%lambda_light(ipa) = sngloff(lambda_tot,tiny_offset) !------------------------------------------------------------------------------! else @@ -817,97 +954,205 @@ subroutine sfcrad_ed(cosz,cosaoi,csite,mzg,mzs,ntext_soil,ncol_soil,maxcohort,tu + albedo_ground_nir * nir_beam_norm & + albedo_ground_par * par_diff_norm & + albedo_ground_nir * nir_diff_norm - csite%lambda_light(ipa) = 0.0 end if - !----- Absorption rates of PAR, rshort, and rlong of the vegetation. -------------! - il = 0 - - do ico = cpatch%ncohorts,1,-1 - if (cpatch%leaf_resolvable(ico) .or. cpatch%wood_resolvable(ico)) then - il = il + 1 - ipft = pft_array(il) - - !---------------------------------------------------------------------------! - ! Find the weight for leaves and branchwood. This is a weighted aver- ! - ! age between the area and absorptance. We must treat the visible and near ! - ! infrared separately. ! - !---------------------------------------------------------------------------! - wleaf_vis = sngloff ( ( clumping_factor(ipft) & - * (1.d0 - leaf_scatter_vis(ipft)) & - * LAI_array(il) ) & - / ( clumping_factor(ipft) & - * (1.d0 - leaf_scatter_vis(ipft)) & - * LAI_array(il) & - + (1.d0 - wood_scatter_vis(ipft)) & - * WAI_array(il) ), tiny_offset ) - wleaf_nir = sngloff ( ( clumping_factor(ipft) & - * (1.d0 - leaf_scatter_nir(ipft)) & - * LAI_array(il) ) & - / ( clumping_factor(ipft) & - * (1.d0 - leaf_scatter_nir(ipft)) & - * LAI_array(il) & - + (1.d0 - wood_scatter_nir(ipft)) & - * WAI_array(il) ), tiny_offset ) - wleaf_tir = sngloff( ( leaf_emis(ipft) * LAI_array(il) ) & - / ( leaf_emis(ipft) * LAI_array(il) & - + wood_emis(ipft) * WAI_array(il) ), tiny_offset ) - wwood_vis = 1. - wleaf_vis - wwood_nir = 1. - wleaf_nir - wwood_tir = 1. - wleaf_tir + !---------------------------------------------------------------------------------! + ! Absorption rates of PAR, rshort, and rlong of the vegetation. Here we ! + ! check again whether we are solving big leaf or size- and age-structure. ! + !---------------------------------------------------------------------------------! + select case (ibigleaf) + case (0) + !------------------------------------------------------------------------------! + ! Size- and age-structure. We copy the results back to each cohort that is ! + ! resolvable. ! + !------------------------------------------------------------------------------! + il = 0 + do ico = cpatch%ncohorts,1,-1 + if (cpatch%leaf_resolvable(ico) .or. cpatch%wood_resolvable(ico)) then + il = il + 1 + ipft = pft_array(il) + + !------------------------------------------------------------------------! + ! Find the weight for leaves and branchwood. This is a weighted ! + ! average between the area and absorptance. We must treat the visible ! + ! and near infrared separately. ! + !------------------------------------------------------------------------! + wleaf_vis = sngloff ( ( clumping_factor(ipft) & + * (1.d0 - leaf_scatter_vis(ipft)) & + * LAI_array(il) ) & + / ( clumping_factor(ipft) & + * (1.d0 - leaf_scatter_vis(ipft)) & + * LAI_array(il) & + + (1.d0 - wood_scatter_vis(ipft)) & + * WAI_array(il) ), tiny_offset ) + wleaf_nir = sngloff ( ( clumping_factor(ipft) & + * (1.d0 - leaf_scatter_nir(ipft)) & + * LAI_array(il) ) & + / ( clumping_factor(ipft) & + * (1.d0 - leaf_scatter_nir(ipft)) & + * LAI_array(il) & + + (1.d0 - wood_scatter_nir(ipft)) & + * WAI_array(il) ), tiny_offset ) + wleaf_tir = sngloff( ( leaf_emis(ipft) * LAI_array(il) ) & + / ( leaf_emis(ipft) * LAI_array(il) & + + wood_emis(ipft) * WAI_array(il) ), tiny_offset ) + wwood_vis = 1. - wleaf_vis + wwood_nir = 1. - wleaf_nir + wwood_tir = 1. - wleaf_tir + !------------------------------------------------------------------------! + + + + + + !----- Find the near infrared absorption, so we average things properly. ! + nir_v_beam = rshort_v_beam_array (il) - par_v_beam_array (il) + nir_v_diffuse = rshort_v_diffuse_array (il) - par_v_diffuse_array (il) + !------------------------------------------------------------------------! + + + + + !------------------------------------------------------------------------! + ! Split the layer radiation between leaf and branchwood. ! + !------------------------------------------------------------------------! + !------ Visible (PAR), only leaves need this (photsynthesis model). -----! + cpatch%par_l_beam (ico) = par_v_beam_array (il) * wleaf_vis + cpatch%par_l_diffuse (ico) = par_v_diffuse_array (il) * wleaf_vis + !------ Total short wave radiation (PAR+NIR). ---------------------------! + cpatch%rshort_l_beam (ico) = par_v_beam_array (il) * wleaf_vis & + + nir_v_beam * wleaf_nir + cpatch%rshort_l_diffuse (ico) = par_v_diffuse_array (il) * wleaf_vis & + + nir_v_diffuse * wleaf_nir + cpatch%rshort_w_beam (ico) = par_v_beam_array (il) * wwood_vis & + + nir_v_beam * wwood_nir + cpatch%rshort_w_diffuse (ico) = par_v_diffuse_array (il) * wwood_vis & + + nir_v_diffuse * wwood_nir + !----- Thermal infra-red (long wave). -----------------------------------! + cpatch%rlong_l_surf (ico) = lw_v_surf_array (il) * wleaf_tir + cpatch%rlong_l_incid (ico) = lw_v_incid_array (il) * wleaf_tir + cpatch%rlong_w_surf (ico) = lw_v_surf_array (il) * wwood_tir + cpatch%rlong_w_incid (ico) = lw_v_incid_array (il) * wwood_tir + !------------------------------------------------------------------------! + + + !----- Save the light levels. -------------------------------------------! + cpatch%light_level (ico) = sngloff(light_level_array (il) & + ,tiny_offset ) + cpatch%light_level_beam (ico) = sngloff(light_beam_level_array(il) & + ,tiny_offset ) + cpatch%light_level_diff (ico) = sngloff(light_diff_level_array(il) & + ,tiny_offset ) + !------------------------------------------------------------------------! + end if !---------------------------------------------------------------------------! + end do + !------------------------------------------------------------------------------! - - - - !----- Find the near infrared absorption, so we average things properly. ---! - nir_v_beam = rshort_v_beam_array (il) - par_v_beam_array (il) - nir_v_diffuse = rshort_v_diffuse_array (il) - par_v_diffuse_array (il) + case (1) + !------------------------------------------------------------------------------! + ! Big leaf solver. Radiation flux is an extensive variable since its ! + ! units are J/m2/s. Therefore we just need to add the fluxes back. For the ! + ! light levels, we cheat and assign the value in the middle. ! + !------------------------------------------------------------------------------! + if (cpatch%leaf_resolvable(1) .or. cpatch%wood_resolvable(1)) then + do il=1,cohort_count + ipft = pft_array(il) + + !------------------------------------------------------------------------! + ! Find the weight for leaves and branchwood. This is a weighted ! + ! average between the area and absorptance. We must treat the ! + ! visible and near infrared separately. ! + !------------------------------------------------------------------------! + wleaf_vis = sngloff ( ( clumping_factor(ipft) & + * (1.d0 - leaf_scatter_vis(ipft)) & + * LAI_array(il) ) & + / ( clumping_factor(ipft) & + * (1.d0 - leaf_scatter_vis(ipft)) & + * LAI_array(il) & + + (1.d0 - wood_scatter_vis(ipft)) & + * WAI_array(il) ), tiny_offset ) + wleaf_nir = sngloff ( ( clumping_factor(ipft) & + * (1.d0 - leaf_scatter_nir(ipft)) & + * LAI_array(il) ) & + / ( clumping_factor(ipft) & + * (1.d0 - leaf_scatter_nir(ipft)) & + * LAI_array(il) & + + (1.d0 - wood_scatter_nir(ipft)) & + * WAI_array(il) ), tiny_offset ) + wleaf_tir = sngloff( ( leaf_emis(ipft) * LAI_array(il) ) & + / ( leaf_emis(ipft) * LAI_array(il) & + + wood_emis(ipft) * WAI_array(il) ), tiny_offset ) + wwood_vis = 1. - wleaf_vis + wwood_nir = 1. - wleaf_nir + wwood_tir = 1. - wleaf_tir + !------------------------------------------------------------------------! + + + + + + !------------------------------------------------------------------------! + ! Find the near infrared absorption, so we average things ! + ! properly. ! + !------------------------------------------------------------------------! + nir_v_beam = rshort_v_beam_array (il) - par_v_beam_array (il) + nir_v_diffuse = rshort_v_diffuse_array (il) - par_v_diffuse_array (il) + !------------------------------------------------------------------------! + + + + + !------------------------------------------------------------------------! + ! Split the layer radiation between leaf and branchwood. ! + !------------------------------------------------------------------------! + !------ Visible (PAR), only leaves need this (photsynthesis model). -----! + cpatch%par_l_beam (1) = cpatch%par_l_beam (1) & + + par_v_beam_array (il) * wleaf_vis + cpatch%par_l_diffuse (1) = cpatch%par_l_diffuse (1) & + + par_v_diffuse_array (il) * wleaf_vis + !------ Total short wave radiation (PAR+NIR). ---------------------------! + cpatch%rshort_l_beam (1) = cpatch%rshort_l_beam (1) & + + par_v_beam_array (il) * wleaf_vis & + + nir_v_beam * wleaf_nir + cpatch%rshort_l_diffuse (1) = cpatch%rshort_l_diffuse (1) & + + par_v_diffuse_array (il) * wleaf_vis & + + nir_v_diffuse * wleaf_nir + cpatch%rshort_w_beam (1) = cpatch%rshort_w_beam (1) & + + par_v_beam_array (il) * wwood_vis & + + nir_v_beam * wwood_nir + cpatch%rshort_w_diffuse (1) = cpatch%rshort_w_diffuse (1) & + + par_v_diffuse_array (il) * wwood_vis & + + nir_v_diffuse * wwood_nir + !----- Thermal infra-red (long wave). -----------------------------------! + cpatch%rlong_l_surf (1) = cpatch%rlong_l_surf (1) & + + lw_v_surf_array (il) * wleaf_tir + cpatch%rlong_l_incid (1) = cpatch%rlong_l_incid (1) & + + lw_v_incid_array (il) * wleaf_tir + cpatch%rlong_w_surf (1) = cpatch%rlong_w_surf (1) & + + lw_v_surf_array (il) * wwood_tir + cpatch%rlong_w_incid (1) = cpatch%rlong_w_incid (1) & + + lw_v_incid_array (il) * wwood_tir + !------------------------------------------------------------------------! + end do !---------------------------------------------------------------------------! - - !---------------------------------------------------------------------------! - ! Split the layer radiation between leaf and branchwood. ! - !---------------------------------------------------------------------------! - !------ Visible (PAR), only leaves need this (photsynthesis model). --------! - cpatch%par_l_beam (ico) = par_v_beam_array (il) * wleaf_vis - cpatch%par_l_diffuse (ico) = par_v_diffuse_array (il) * wleaf_vis - !------ Total short wave radiation (PAR+NIR). ------------------------------! - cpatch%rshort_l_beam (ico) = par_v_beam_array (il) * wleaf_vis & - + nir_v_beam * wleaf_nir - cpatch%rshort_l_diffuse (ico) = par_v_diffuse_array (il) * wleaf_vis & - + nir_v_diffuse * wleaf_nir - cpatch%rshort_w_beam (ico) = par_v_beam_array (il) * wwood_vis & - + nir_v_beam * wwood_nir - cpatch%rshort_w_diffuse (ico) = par_v_diffuse_array (il) * wwood_vis & - + nir_v_diffuse * wwood_nir - !----- Thermal infra-red (long wave). --------------------------------------! - cpatch%rlong_l_surf (ico) = lw_v_surf_array (il) * wleaf_tir - cpatch%rlong_l_incid (ico) = lw_v_incid_array (il) * wleaf_tir - cpatch%rlong_w_surf (ico) = lw_v_surf_array (il) * wwood_tir - cpatch%rlong_w_incid (ico) = lw_v_incid_array (il) * wwood_tir - !---------------------------------------------------------------------------! - - - !----- Save the light levels. ----------------------------------------------! - cpatch%lambda_light (ico) = sngloff(lambda_array (il) & + !----- Save the light levels as the median level. --------------------------! + il = ceiling(real(cohort_count)/2.0) + cpatch%light_level (1) = sngloff(light_level_array (il) & ,tiny_offset ) - cpatch%beamext_level (ico) = sngloff(beam_level_array (il) & + cpatch%light_level_beam (1) = sngloff(light_beam_level_array(il) & ,tiny_offset ) - cpatch%diffext_level (ico) = sngloff(diff_level_array (il) & - ,tiny_offset ) - cpatch%light_level (ico) = sngloff(light_level_array (il) & - ,tiny_offset ) - cpatch%light_level_beam (ico) = sngloff(light_beam_level_array(il) & - ,tiny_offset ) - cpatch%light_level_diff (ico) = sngloff(light_diff_level_array(il) & + cpatch%light_level_diff (1) = sngloff(light_diff_level_array(il) & ,tiny_offset ) !---------------------------------------------------------------------------! end if - end do + !------------------------------------------------------------------------------! + end select + !---------------------------------------------------------------------------------! else @@ -970,6 +1215,33 @@ subroutine sfcrad_ed(cosz,cosaoi,csite,mzg,mzs,ntext_soil,ncol_soil,maxcohort,tu end if !------------------------------------------------------------------------------------! end do + + + !---------------------------------------------------------------------------------------! + ! Deallocate arrays. ! + !---------------------------------------------------------------------------------------! + deallocate (pft_array ) + deallocate (leaf_temp_array ) + deallocate (wood_temp_array ) + deallocate (lai_array ) + deallocate (wai_array ) + deallocate (CA_array ) + deallocate (htop_array ) + deallocate (hbot_array ) + deallocate (lambda_array ) + deallocate (beam_level_array ) + deallocate (diff_level_array ) + deallocate (light_level_array ) + deallocate (light_beam_level_array ) + deallocate (light_diff_level_array ) + deallocate (par_v_beam_array ) + deallocate (rshort_v_beam_array ) + deallocate (par_v_diffuse_array ) + deallocate (rshort_v_diffuse_array ) + deallocate (lw_v_surf_array ) + deallocate (lw_v_incid_array ) + !---------------------------------------------------------------------------------------! + return end subroutine sfcrad_ed !==========================================================================================! diff --git a/ED/src/dynamics/reproduction.f90 b/ED/src/dynamics/reproduction.f90 index 86531e146..b0215d496 100644 --- a/ED/src/dynamics/reproduction.f90 +++ b/ED/src/dynamics/reproduction.f90 @@ -5,45 +5,51 @@ ! want it, in which case the seedling biomass will go to the litter pools. ! !------------------------------------------------------------------------------------------! subroutine reproduction(cgrid, month) - use ed_state_vars , only : edtype & ! structure - , polygontype & ! structure - , sitetype & ! structure - , patchtype & ! structure - , allocate_patchtype & ! subroutine - , copy_patchtype & ! subroutine - , deallocate_patchtype ! ! subroutine - use pft_coms , only : recruittype & ! structure - , zero_recruit & ! subroutine - , copy_recruit & ! subroutine - , seedling_mortality & ! intent(in) - , c2n_stem & ! intent(in) - , l2n_stem & ! intent(in) - , min_recruit_size & ! intent(in) - , c2n_recruit & ! intent(in) - , seed_rain & ! intent(in) - , include_pft & ! intent(in) - , include_pft_ag & ! intent(in) - , qsw & ! intent(in) - , q & ! intent(in) - , sla & ! intent(in) - , hgt_min & ! intent(in) - , plant_min_temp ! ! intent(in) - use decomp_coms , only : f_labile ! ! intent(in) - use ed_max_dims , only : n_pft ! ! intent(in) - use fuse_fiss_utils , only : sort_cohorts & ! subroutine - , terminate_cohorts & ! subroutine - , fuse_cohorts & ! subroutine - , split_cohorts ! ! subroutine - use phenology_coms , only : repro_scheme ! ! intent(in) - use mem_polygons , only : maxcohort ! ! intent(in) - use consts_coms , only : pio4 ! ! intent(in) - use ed_therm_lib , only : calc_veg_hcap ! ! function - use allometry , only : dbh2bd & ! function - , dbh2bl & ! function - , h2dbh & ! function - , ed_biomass & ! function - , area_indices ! ! subroutine - use grid_coms , only : nzg ! ! intent(in) + use ed_state_vars , only : edtype & ! structure + , polygontype & ! structure + , sitetype & ! structure + , patchtype & ! structure + , allocate_patchtype & ! subroutine + , copy_patchtype & ! subroutine + , deallocate_patchtype ! ! subroutine + use pft_coms , only : recruittype & ! structure + , zero_recruit & ! subroutine + , copy_recruit & ! subroutine + , seedling_mortality & ! intent(in) + , c2n_stem & ! intent(in) + , l2n_stem & ! intent(in) + , min_recruit_size & ! intent(in) + , one_plant_c & ! intent(in) + , c2n_recruit & ! intent(in) + , seed_rain & ! intent(in) + , include_pft & ! intent(in) + , include_pft_ag & ! intent(in) + , qsw & ! intent(in) + , q & ! intent(in) + , agf_bs & ! intent(in) + , sla & ! intent(in) + , hgt_min & ! intent(in) + , plant_min_temp ! ! intent(in) + use decomp_coms , only : f_labile ! ! intent(in) + use ed_max_dims , only : n_pft ! ! intent(in) + use fuse_fiss_utils , only : sort_cohorts & ! subroutine + , terminate_cohorts & ! subroutine + , fuse_cohorts & ! subroutine + , split_cohorts & ! subroutine + , rescale_patches ! ! subroutine + use phenology_coms , only : repro_scheme ! ! intent(in) + use mem_polygons , only : maxcohort ! ! intent(in) + use consts_coms , only : pio4 ! ! intent(in) + use ed_therm_lib , only : calc_veg_hcap ! ! function + use allometry , only : dbh2bd & ! function + , dbh2bl & ! function + , h2dbh & ! function + , ed_biomass & ! function + , area_indices & ! subroutine + , dbh2krdepth ! ! function + use grid_coms , only : nzg ! ! intent(in) + use ed_misc_coms , only : ibigleaf ! ! intent(in) + use phenology_aux , only : pheninit_balive_bstorage ! ! intent(in) implicit none !----- Arguments -----------------------------------------------------------------------! type(edtype) , target :: cgrid @@ -65,6 +71,13 @@ subroutine reproduction(cgrid, month) logical :: late_spring real :: elim_nplant real :: elim_lai + real :: nplant_inc + real :: bleaf_plant + real :: bdead_plant + real :: broot_plant + real :: bsapwood_plant + real :: balive_plant + real :: rec_biomass !----- Saved variables -----------------------------------------------------------------! logical , save :: first_time = .true. !---------------------------------------------------------------------------------------! @@ -80,263 +93,450 @@ subroutine reproduction(cgrid, month) if (repro_scheme == 0) seedling_mortality(1:n_pft) = 1.0 first_time = .false. end if + !---------------------------------------------------------------------------------------! - !----- The big loops start here. -------------------------------------------------------! - polyloop: do ipy = 1,cgrid%npolygons - + + !---------------------------------------------------------------------------------------! + ! Decide which vegetation structure to use. ! + !---------------------------------------------------------------------------------------! + select case (ibigleaf) + case (0) !------------------------------------------------------------------------------------! - ! Check whether this is late spring/early summer. This is needed for temperate ! - ! broadleaf deciduous trees. Late spring means June in the Northern Hemisphere, or ! - ! December in the Southern Hemisphere. ! + ! Size- and age_structure reproduction ! !------------------------------------------------------------------------------------! - late_spring = (cgrid%lat(ipy) >= 0.0 .and. month == 6) .or. & - (cgrid%lat(ipy) < 0.0 .and. month == 12) - cpoly => cgrid%polygon(ipy) - siteloop_sort: do isi = 1,cpoly%nsites - csite => cpoly%site(isi) + !----- The big loops start here. -------------------------------------------------------! + polyloop: do ipy = 1,cgrid%npolygons + !---------------------------------------------------------------------------------! - ! Cohorts may have grown differently, so we need to sort them by size. ! + ! Check whether this is late spring/early summer. This is needed for ! + ! temperate broadleaf deciduous trees. Late spring means June in the Northern ! + ! Hemisphere, or December in the Southern Hemisphere. ! !---------------------------------------------------------------------------------! - patchloop_sort: do ipa = 1,csite%npatches - cpatch => csite%patch(ipa) - call sort_cohorts(cpatch) - end do patchloop_sort - end do siteloop_sort - - !------- Update the repro arrays. ---------------------------------------------------! - call seed_dispersal(cpoly,late_spring) - !------------------------------------------------------------------------------------! + late_spring = (cgrid%lat(ipy) >= 0.0 .and. month == 6) .or. & + (cgrid%lat(ipy) < 0.0 .and. month == 12) - siteloop: do isi = 1,cpoly%nsites - csite => cpoly%site(isi) + cpoly => cgrid%polygon(ipy) + siteloop_sort: do isi = 1,cpoly%nsites + csite => cpoly%site(isi) + !------------------------------------------------------------------------------! + ! Cohorts may have grown differently, so we need to sort them by size. ! + !------------------------------------------------------------------------------! + patchloop_sort: do ipa = 1,csite%npatches + cpatch => csite%patch(ipa) + call sort_cohorts(cpatch) + end do patchloop_sort + end do siteloop_sort + + !------- Update the repro arrays. ------------------------------------------------! + call seed_dispersal(cpoly,late_spring) !---------------------------------------------------------------------------------! - ! For the recruitment to happen, four requirements must be met: ! - ! 1. PFT is included in this simulation; ! - ! 2. It is not too cold (min_monthly_temp > plant_min_temp - 5) ! - ! 3. We are dealing with EITHER a non-agriculture patch OR ! - ! a PFT that could exist in an agricultural patch. ! - ! 4. There must be sufficient carbon to form the recruits. ! - !---------------------------------------------------------------------------------! - patchloop: do ipa = 1,csite%npatches - inew = 0 - call zero_recruit(n_pft,recruit) - cpatch => csite%patch(ipa) - !---- This time we loop over PFTs, not cohorts. -------------------------------! - pftloop: do ipft = 1, n_pft + siteloop: do isi = 1,cpoly%nsites + csite => cpoly%site(isi) - !---------------------------------------------------------------------------! - ! Check to make sure we are including the PFT and that it is not too ! - ! cold. ! - !---------------------------------------------------------------------------! - if( include_pft(ipft) .and. & - cpoly%min_monthly_temp(isi) >= plant_min_temp(ipft) - 5.0 .and. & - repro_scheme /= 0 ) then + !------------------------------------------------------------------------------! + ! For the recruitment to happen, four requirements must be met: ! + ! 1. PFT is included in this simulation; ! + ! 2. It is not too cold (min_monthly_temp > plant_min_temp - 5) ! + ! 3. We are dealing with EITHER a non-agriculture patch OR ! + ! a PFT that could exist in an agricultural patch. ! + ! 4. There must be sufficient carbon to form the recruits. ! + !------------------------------------------------------------------------------! + patchloop: do ipa = 1,csite%npatches + inew = 0 + call zero_recruit(n_pft,recruit) + cpatch => csite%patch(ipa) + + !---- This time we loop over PFTs, not cohorts. ----------------------------! + pftloop: do ipft = 1, n_pft + !------------------------------------------------------------------------! - ! Make sure that this is not agriculture or that it is fine for this ! - ! PFT to be in an agriculture patch. ! + ! Check to make sure we are including the PFT and that it is not too ! + ! cold. ! !------------------------------------------------------------------------! - if(csite%dist_type(ipa) /= 1 .or. include_pft_ag(ipft)) then + if( include_pft(ipft) .and. & + cpoly%min_monthly_temp(isi) >= plant_min_temp(ipft) - 5.0 .and. & + repro_scheme /= 0 ) then !---------------------------------------------------------------------! - ! We assign the recruit in the temporary recruitment structure. ! + ! Make sure that this is not agriculture or that it is fine for ! + ! this PFT to be in an agriculture patch. ! !---------------------------------------------------------------------! - rectest%pft = ipft - rectest%leaf_temp = csite%can_temp(ipa) - rectest%wood_temp = csite%can_temp(ipa) - rectest%hite = hgt_min(ipft) - rectest%dbh = h2dbh(rectest%hite, ipft) - rectest%bdead = dbh2bd(rectest%dbh, ipft) - rectest%bleaf = dbh2bl(rectest%dbh, ipft) - rectest%balive = rectest%bleaf & - * (1.0 + q(ipft) + qsw(ipft) * rectest%hite) - rectest%nplant = csite%repro(ipft,ipa) & - / (rectest%balive + rectest%bdead) - - if(include_pft(ipft)) then - rectest%nplant = rectest%nplant + seed_rain(ipft) + if(csite%dist_type(ipa) /= 1 .or. include_pft_ag(ipft)) then + + !------------------------------------------------------------------! + ! We assign the recruit in the temporary recruitment structure. ! + !------------------------------------------------------------------! + rectest%pft = ipft + rectest%leaf_temp = csite%can_temp(ipa) + rectest%wood_temp = csite%can_temp(ipa) + rectest%leaf_temp_pv=csite%can_temp(ipa) + rectest%wood_temp_pv=csite%can_temp(ipa) + rectest%hite = hgt_min(ipft) + rectest%dbh = h2dbh(rectest%hite, ipft) + rectest%krdepth = dbh2krdepth(rectest%hite,rectest%dbh & + ,rectest%pft,cpoly%lsl(isi)) + rectest%bdead = dbh2bd(rectest%dbh, ipft) + + call pheninit_balive_bstorage(nzg,rectest%pft,rectest%krdepth & + ,rectest%hite,rectest%dbh & + ,csite%soil_water(:,ipa) & + ,cpoly%ntext_soil(:,isi) & + ,cpoly%green_leaf_factor(:,isi) & + ,rectest%paw_avg,rectest%elongf & + ,rectest%phenology_status & + ,rectest%bleaf,rectest%broot & + ,rectest%bsapwood,rectest%balive & + ,rectest%bstorage) + + rectest%nplant = csite%repro(ipft,ipa) & + / ( rectest%balive + rectest%bdead & + + rectest%bstorage) + + if (include_pft(ipft)) then + rectest%nplant = rectest%nplant + seed_rain(ipft) + end if + + !----- If there is enough carbon, form the recruits. --------------! + rec_biomass = rectest%nplant * ( rectest%balive + rectest%bdead & + + rectest%bstorage ) + + select case (repro_scheme) + case (3) + if (rec_biomass > min_recruit_size(ipft) .and. & + rectest%phenology_status == 0) then + inew = inew + 1 + call copy_recruit(rectest,recruit(inew)) + !----- Reset the carbon available for reproduction. ---------! + csite%repro(ipft,ipa) = 0.0 + end if + case default + if (rec_biomass > min_recruit_size(ipft)) then + inew = inew + 1 + call copy_recruit(rectest,recruit(inew)) + !----- Reset the carbon available for reproduction. ---------! + csite%repro(ipft,ipa) = 0.0 + end if + end select + !------------------------------------------------------------------! + else + !------------------------------------------------------------------! + ! If we have reached this branch, we are in an agricultural ! + ! patch. Send the seed litter to the soil pools for ! + ! decomposition. ! + !------------------------------------------------------------------! + csite%fast_soil_N(ipa) = csite%fast_soil_N(ipa) & + + csite%repro(ipft,ipa) / c2n_recruit(ipft) + csite%fast_soil_C(ipa) = csite%fast_soil_C(ipa) & + + csite%repro(ipft,ipa) + csite%repro(ipft,ipa) = 0.0 + !------------------------------------------------------------------! end if + !---------------------------------------------------------------------! + end if + !------------------------------------------------------------------------! + end do pftloop + !---------------------------------------------------------------------------! - ! If there is enough carbon, form the recruits. - if ( rectest%nplant * (rectest%balive + rectest%bdead) > & - min_recruit_size(ipft)) then - inew = inew + 1 - call copy_recruit(rectest,recruit(inew)) - !----- Reset the carbon available for reproduction. ---------------! - csite%repro(ipft,ipa) = 0.0 - end if - else + + !----- Update the number of cohorts with the recently created. -------------! + ncohorts_new = cpatch%ncohorts + inew + + !---------------------------------------------------------------------------! + ! The number of recruits is now known. If there is any recruit, then we ! + ! allocate the temporary patch vector with the current number plus the ! + ! number of recruits. ! + !---------------------------------------------------------------------------! + if (ncohorts_new > cpatch%ncohorts) then + nullify(temppatch) + allocate(temppatch) + call allocate_patchtype(temppatch,cpatch%ncohorts) + + !----- Fill the temp space with the current patches. --------------------! + call copy_patchtype(cpatch,temppatch,1,cpatch%ncohorts,1,cpatch%ncohorts) + + !----- Deallocate the current patch. ------------------------------------! + call deallocate_patchtype(cpatch) + + !----- Reallocate the current site. -------------------------------------! + call allocate_patchtype(cpatch,ncohorts_new) + + !----- Transfer the temp values back in. --------------------------------! + call copy_patchtype(temppatch,cpatch,1,temppatch%ncohorts & + ,1,temppatch%ncohorts) + + inew = 0 + recloop: do ico = temppatch%ncohorts+1,ncohorts_new !---------------------------------------------------------------------! - ! If we have reached this branch, we are in an agricultural ! - ! patch. Send the seed litter to the soil pools for decomposition. ! + ! Add the recruits, copying the information from the recruitment ! + ! table, and derive other variables or assume standard initial ! + ! values. ! + !---------------------------------------------------------------------! + inew = inew + 1 + + !----- Copy from recruitment table (I). ------------------------------! + cpatch%pft(ico) = recruit(inew)%pft + cpatch%hite(ico) = recruit(inew)%hite + cpatch%dbh(ico) = recruit(inew)%dbh + !---------------------------------------------------------------------! + + !----- Carry out standard initialization. ----------------------------! + call init_ed_cohort_vars(cpatch,ico,cpoly%lsl(isi)) !---------------------------------------------------------------------! - csite%fast_soil_N(ipa) = csite%fast_soil_N(ipa) & - + csite%repro(ipft,ipa) / c2n_recruit(ipft) - csite%fast_soil_C(ipa) = csite%fast_soil_C(ipa) & - + csite%repro(ipft,ipa) - csite%repro(ipft,ipa) = 0.0 - end if - end if - end do pftloop - !----- Update the number of cohorts with the recently created. ----------------! - ncohorts_new = cpatch%ncohorts + inew + + !----- Copy from recruitment table (II). -----------------------------! + cpatch%nplant (ico) = recruit(inew)%nplant + cpatch%bdead (ico) = recruit(inew)%bdead + cpatch%paw_avg (ico) = recruit(inew)%paw_avg + cpatch%elongf (ico) = recruit(inew)%elongf + cpatch%phenology_status(ico) = recruit(inew)%phenology_status + cpatch%bleaf (ico) = recruit(inew)%bleaf + cpatch%broot (ico) = recruit(inew)%broot + cpatch%bsapwood (ico) = recruit(inew)%bsapwood + cpatch%balive (ico) = recruit(inew)%balive + cpatch%bstorage (ico) = recruit(inew)%bstorage + cpatch%leaf_temp (ico) = recruit(inew)%leaf_temp + cpatch%wood_temp (ico) = recruit(inew)%wood_temp + cpatch%leaf_temp_pv (ico) = recruit(inew)%leaf_temp_pv + cpatch%wood_temp_pv (ico) = recruit(inew)%wood_temp_pv + !---------------------------------------------------------------------! + + + + !----- Initialise the next variables with zeroes... ------------------! + cpatch%leaf_water(ico) = 0.0 + cpatch%leaf_fliq (ico) = 0.0 + cpatch%wood_water(ico) = 0.0 + cpatch%wood_fliq (ico) = 0.0 + !---------------------------------------------------------------------! + + + !---------------------------------------------------------------------! + ! Computing initial AGB and Basal Area. Their derivatives will be ! + ! zero. ! + !---------------------------------------------------------------------! + cpatch%agb(ico) = ed_biomass(cpatch%bdead(ico),cpatch%balive(ico) & + ,cpatch%bleaf(ico),cpatch%pft(ico) & + ,cpatch%hite(ico) & + ,cpatch%bstorage(ico) & + ,cpatch%bsapwood(ico)) + cpatch%basarea(ico) = pio4 * cpatch%dbh(ico) * cpatch%dbh(ico) + cpatch%dagb_dt(ico) = 0.0 + cpatch%dba_dt(ico) = 0.0 + cpatch%ddbh_dt(ico) = 0.0 + !---------------------------------------------------------------------! + ! Setting new_recruit_flag to 1 indicates that this cohort is ! + ! included when we tally agb_recruit, basal_area_recruit. ! + !---------------------------------------------------------------------! + cpatch%new_recruit_flag(ico) = 1 + + !---------------------------------------------------------------------! + ! Obtain derived properties. ! + !---------------------------------------------------------------------! + !----- Find LAI, WAI, and CAI. ---------------------------------------! + call area_indices(cpatch%nplant(ico),cpatch%bleaf(ico) & + ,cpatch%bdead(ico),cpatch%balive(ico) & + ,cpatch%dbh(ico),cpatch%hite(ico),cpatch%pft(ico) & + ,cpatch%sla(ico),cpatch%lai(ico),cpatch%wai(ico) & + ,cpatch%crown_area(ico),cpatch%bsapwood(ico)) + !----- Find heat capacity and vegetation internal energy. ------------! + call calc_veg_hcap(cpatch%bleaf(ico),cpatch%bdead(ico) & + ,cpatch%bsapwood(ico),cpatch%nplant(ico) & + ,cpatch%pft(ico) & + ,cpatch%leaf_hcap(ico),cpatch%wood_hcap(ico)) + + cpatch%leaf_energy(ico) = cpatch%leaf_hcap(ico)*cpatch%leaf_temp(ico) + cpatch%wood_energy(ico) = cpatch%wood_hcap(ico)*cpatch%wood_temp(ico) + + call is_resolvable(csite,ipa,ico,cpoly%green_leaf_factor(:,isi)) + + !----- Update number of cohorts in this site. ------------------------! + csite%cohort_count(ipa) = csite%cohort_count(ipa) + 1 + end do recloop + + !---- Remove the temporary patch. ---------------------------------------! + call deallocate_patchtype(temppatch) + deallocate(temppatch) + end if + end do patchloop + !------------------------------------------------------------------------------! - ! The number of recruits is now known. If there is any recruit, then we ! - ! allocate the temporary patch vector with the current number plus the number ! - ! of recruits. ! + ! Now that recruitment has occured, terminate, fuse, split, and re-sort. ! !------------------------------------------------------------------------------! - if (ncohorts_new > cpatch%ncohorts) then - nullify(temppatch) - allocate(temppatch) - call allocate_patchtype(temppatch,cpatch%ncohorts) - - !----- Fill the temp space with the current patches. -----------------------! - call copy_patchtype(cpatch,temppatch,1,cpatch%ncohorts,1,cpatch%ncohorts) + update_patch_loop: do ipa = 1,csite%npatches + cpatch => csite%patch(ipa) + + if(cpatch%ncohorts > 0 .and. maxcohort >= 0) then + call terminate_cohorts(csite,ipa,elim_nplant,elim_lai) + call fuse_cohorts(csite,ipa, cpoly%green_leaf_factor(:,isi) & + ,cpoly%lsl(isi)) + call split_cohorts(cpatch, cpoly%green_leaf_factor(:,isi),cpoly%lsl(isi)) + end if - !----- Deallocate the current patch. ---------------------------------------! - call deallocate_patchtype(cpatch) + !----- Sort the cohorts by height. -----------------------------------------! + call sort_cohorts(cpatch) - !----- Reallocate the current site. ----------------------------------------! - call allocate_patchtype(cpatch,ncohorts_new) + !----- Update the number of cohorts (this is redundant...). ----------------! + csite%cohort_count(ipa) = cpatch%ncohorts - !----- Transfer the temp values back in. -----------------------------------! - call copy_patchtype(temppatch,cpatch,1,temppatch%ncohorts & - ,1,temppatch%ncohorts) + !----- Since cohorts may have changed, update patch properties... ----------! + call update_patch_derived_props(csite,cpoly%lsl(isi),cpoly%met(isi)%prss & + ,ipa) + call update_budget(csite,cpoly%lsl(isi),ipa,ipa) + end do update_patch_loop - inew = 0 - recloop: do ico = temppatch%ncohorts+1,ncohorts_new - !------------------------------------------------------------------------! - ! Add the recruits, copying the information from the recruitment ! - ! table, and derive other variables or assume standard initial values. ! - !------------------------------------------------------------------------! - inew = inew + 1 + !----- Since patch properties may have changed, update site properties... -----! + call update_site_derived_props(cpoly,0,isi) + + !----- Reset minimum monthly temperature. -------------------------------------! + cpoly%min_monthly_temp(isi) = huge(1.) + end do siteloop + !---------------------------------------------------------------------------------! + end do polyloop + !------------------------------------------------------------------------------------! - !----- Copy from recruitment table (I). ---------------------------------! - cpatch%pft(ico) = recruit(inew)%pft - cpatch%hite(ico) = recruit(inew)%hite - cpatch%dbh(ico) = recruit(inew)%dbh - !------------------------------------------------------------------------! - !----- Carry out standard initialization. -------------------------------! - call init_ed_cohort_vars(cpatch,ico,cpoly%lsl(isi)) - !------------------------------------------------------------------------! + case (1) + !------------------------------------------------------------------------------------! + ! 'big leaf' ED ! + ! Growth and reproduction are done together as there is no vertical structure in ! + ! big leaf ED so the cohorts cannot grow vertically. Therefore daily NPP is ! + ! is accumulated and monthly the nplant of each cohort is increased (1 cohort per ! + ! patch and 1 patch per pft and disturbance type). + !------------------------------------------------------------------------------------! - !----- Copy from recruitment table (II). --------------------------------! - cpatch%bdead(ico) = recruit(inew)%bdead - cpatch%nplant(ico) = recruit(inew)%nplant - !------------------------------------------------------------------------! + + !----- The big loops start here. ----------------------------------------------------! + polyloop_big: do ipy = 1,cgrid%npolygons + cpoly => cgrid%polygon(ipy) + late_spring = (cgrid%lat(ipy) >= 0.0 .and. month == 6) .or. & + (cgrid%lat(ipy) < 0.0 .and. month == 12) + !------- Update the repro arrays. ------------------------------------------------! + call seed_dispersal(cpoly,late_spring) + !---------------------------------------------------------------------------------! - !------------------------------------------------------------------------! - ! Even though we brought leaf biomass and biomass of the active ! - ! tissues, we will make them consistent with the initial amount of water ! - ! available. This is done inside pheninit_alive_storage. ! - !------------------------------------------------------------------------! - call pheninit_balive_bstorage(nzg,csite,ipa,ico,cpoly%ntext_soil(:,isi) & - ,cpoly%green_leaf_factor(:,isi)) - !------------------------------------------------------------------------! + siteloop_big: do isi = 1,cpoly%nsites + csite => cpoly%site(isi) + patchloop_big: do ipa = 1,csite%npatches + cpatch => csite%patch(ipa) - !----- Assign temperature after init_ed_cohort_vars... ------------------! - cpatch%leaf_temp(ico) = recruit(inew)%leaf_temp - cpatch%wood_temp(ico) = recruit(inew)%wood_temp + !----------------------------------------------------------------------------! + ! There should only be ONE cohort... if there are more, crash ! + !----------------------------------------------------------------------------! + if (cpatch%ncohorts > 1) then + write (unit=*,fmt='(a,1x,es12.5)') ' + PATCH : ',ipa + write (unit=*,fmt='(a,1x,es12.5)') ' + NCOHORTS: ',cpatch%ncohorts + call fatal_error('NCOHORTS can never be greater than 1 for big-leaf runs' & + ,'reproduction' ,'reproduction.f90') + end if + + cohortloop_big: do ico = 1, cpatch%ncohorts - !----- Initialise the next variables with zeroes... ---------------------! - cpatch%leaf_water(ico) = 0.0 - cpatch%leaf_fliq (ico) = 0.0 - cpatch%wood_water(ico) = 0.0 - cpatch%wood_fliq (ico) = 0.0 - !------------------------------------------------------------------------! + ipft = cpatch%pft(ico) !------------------------------------------------------------------------! - ! Computing initial AGB and Basal Area. Their derivatives will be ! - ! zero. ! - !------------------------------------------------------------------------! - cpatch%agb(ico) = ed_biomass(cpatch%bdead(ico),cpatch%balive(ico) & - ,cpatch%bleaf(ico),cpatch%pft(ico) & - ,cpatch%hite(ico),cpatch%bstorage(ico) & - ,cpatch%bsapwood(ico)) - cpatch%basarea(ico) = pio4 * cpatch%dbh(ico) * cpatch%dbh(ico) - cpatch%dagb_dt(ico) = 0.0 - cpatch%dba_dt(ico) = 0.0 - cpatch%ddbh_dt(ico) = 0.0 + ! Check to make sure that it is not too cold and reproduction is on ! !------------------------------------------------------------------------! - ! Setting new_recruit_flag to 1 indicates that this cohort is ! - ! included when we tally agb_recruit, basal_area_recruit. ! - !------------------------------------------------------------------------! - cpatch%new_recruit_flag(ico) = 1 - - !------------------------------------------------------------------------! - ! Obtain derived properties. ! - !------------------------------------------------------------------------! - !----- Find LAI, WPA, WAI. ----------------------------------------------! - call area_indices(cpatch%nplant(ico),cpatch%bleaf(ico),cpatch%bdead(ico) & - ,cpatch%balive(ico),cpatch%dbh(ico), cpatch%hite(ico) & - ,cpatch%pft(ico),cpatch%sla(ico), cpatch%lai(ico) & - ,cpatch%wpa(ico),cpatch%wai(ico) & - ,cpatch%crown_area(ico),cpatch%bsapwood(ico)) - !----- Find heat capacity and vegetation internal energy. ---------------! - call calc_veg_hcap(cpatch%bleaf(ico),cpatch%bdead(ico) & - ,cpatch%bsapwood(ico),cpatch%nplant(ico) & - ,cpatch%pft(ico) & - ,cpatch%leaf_hcap(ico),cpatch%wood_hcap(ico)) - - cpatch%leaf_energy(ico) = cpatch%leaf_hcap(ico) * cpatch%leaf_temp(ico) - cpatch%wood_energy(ico) = cpatch%wood_hcap(ico) * cpatch%wood_temp(ico) - - call is_resolvable(csite,ipa,ico,cpoly%green_leaf_factor(:,isi)) - - !----- Update number of cohorts in this site. ---------------------------! - csite%cohort_count(ipa) = csite%cohort_count(ipa) + 1 - end do recloop - - !---- Remove the temporary patch. ------------------------------------------! - call deallocate_patchtype(temppatch) - deallocate(temppatch) - end if - end do patchloop - - - !---------------------------------------------------------------------------------! - ! Now that recruitment has occured, terminate, fuse, split, and re-sort. ! - !---------------------------------------------------------------------------------! - update_patch_loop: do ipa = 1,csite%npatches - cpatch => csite%patch(ipa) + if( cpoly%min_monthly_temp(isi) >= plant_min_temp(ipft) - 5.0 .and. & + repro_scheme /= 0 ) then + + nplant_inc = csite%repro(ipft,ipa) / one_plant_c(ipft) + + !------------------------------------------------------------------! + ! Will only reproduce/grow if on-allometry so dont' have to ! + ! worry about elongation factor ! + !------------------------------------------------------------------! + bleaf_plant = dbh2bl(cpatch%dbh(ico),ipft) + bdead_plant = dbh2bd(cpatch%dbh(ico),ipft) + balive_plant = dbh2bl(cpatch%dbh(ico),ipft) * (1.0 + qsw(ipft) & + * cpatch%hite(ico) + q(ipft)) + broot_plant = balive_plant * q(ipft) / (1.0 + qsw(ipft) & + * cpatch%hite(ico) + q(ipft)) + bsapwood_plant = balive_plant * qsw(ipft) * cpatch%hite(ico) & + / (1.0 + qsw(ipft) * cpatch%hite(ico) + q(ipft)) + + cpatch%today_nppleaf(ico) = nplant_inc * bleaf_plant + cpatch%today_nppfroot(ico) = nplant_inc * broot_plant + cpatch%today_nppsapwood(ico)= nplant_inc * bsapwood_plant + cpatch%today_nppwood(ico) = agf_bs(ipft) * nplant_inc & + * bdead_plant + cpatch%today_nppcroot(ico) = (1. - agf_bs(ipft)) * nplant_inc & + * bdead_plant + + cpatch%nplant(ico) = cpatch%nplant(ico) + nplant_inc + + + !----- Reset the carbon available for reproduction. ---------------! + csite%repro(ipft,ipa) = 0.0 - if(cpatch%ncohorts > 0 .and. maxcohort >= 0) then - call terminate_cohorts(csite,ipa,elim_nplant,elim_lai) - call fuse_cohorts(csite,ipa, cpoly%green_leaf_factor(:,isi),cpoly%lsl(isi)) - call split_cohorts(cpatch, cpoly%green_leaf_factor(:,isi),cpoly%lsl(isi)) - end if - !----- Sort the cohorts by height. --------------------------------------------! - call sort_cohorts(cpatch) + !------------------------------------------------------------------! + ! Obtain derived properties these will have changed ! + !------------------------------------------------------------------! + !----- Find LAI, WAI, and CAI. ------------------------------------! + call area_indices(cpatch%nplant(ico),cpatch%bleaf(ico) & + ,cpatch%bdead(ico),cpatch%balive(ico),cpatch%dbh(ico)& + ,cpatch%hite(ico), cpatch%pft(ico),cpatch%sla(ico) & + ,cpatch%lai(ico),cpatch%wai(ico) & + ,cpatch%crown_area(ico),cpatch%bsapwood(ico)) + !----- Find heat capacity and vegetation internal energy. ---------! + call calc_veg_hcap(cpatch%bleaf(ico),cpatch%bdead(ico) & + ,cpatch%bsapwood(ico),cpatch%nplant(ico) & + ,cpatch%pft(ico) & + ,cpatch%leaf_hcap(ico),cpatch%wood_hcap(ico)) + + cpatch%leaf_energy(ico) = cpatch%leaf_hcap(ico) & + * cpatch%leaf_temp(ico) + cpatch%wood_energy(ico) = cpatch%wood_hcap(ico) & + * cpatch%wood_temp(ico) + + call is_resolvable(csite,ipa,ico,cpoly%green_leaf_factor(:,isi)) + end if - !----- Update the number of cohorts (this is redundant...). -------------------! - csite%cohort_count(ipa) = cpatch%ncohorts + end do cohortloop_big + end do patchloop_big + + + !------------------------------------------------------------------------------! + ! Now that recruitment has occured rescale patches and update properties ! + !------------------------------------------------------------------------------! + !call rescale_patches(csite) + + update_patch_loop_big: do ipa = 1,csite%npatches + cpatch => csite%patch(ipa) - !----- Since cohorts may have changed, update patch properties... -------------! - call update_patch_derived_props(csite,cpoly%lsl(isi),cpoly%met(isi)%prss,ipa) - call update_budget(csite,cpoly%lsl(isi),ipa,ipa) - end do update_patch_loop + !----- Update the number of cohorts (this is redundant...). -------------! + csite%cohort_count(ipa) = cpatch%ncohorts - !----- Since patch properties may have changed, update site properties... --------! - call update_site_derived_props(cpoly,0,isi) - - !----- Reset minimum monthly temperature. ----------------------------------------! - cpoly%min_monthly_temp(isi) = huge(1.) - end do siteloop - end do polyloop + !----- Since cohorts may have changed, update patch properties... -------! + call update_patch_derived_props(csite,cpoly%lsl(isi) & + ,cpoly%met(isi)%prss,ipa) + call update_budget(csite,cpoly%lsl(isi),ipa,ipa) + end do update_patch_loop_big + + !----- Since patch properties may have changed, update site properties... -----! + call update_site_derived_props(cpoly,0,isi) + + !----- Reset minimum monthly temperature. -------------------------------------! + cpoly%min_monthly_temp(isi) = huge(1.) + end do siteloop_big + !---------------------------------------------------------------------------------! + end do polyloop_big + !------------------------------------------------------------------------------------! + + end select return end subroutine reproduction !==========================================================================================! @@ -465,6 +665,7 @@ subroutine seed_dispersal(cpoly,late_spring) , nonlocal_dispersal & ! intent(in) , seedling_mortality & ! intent(in) , phenology ! ! intent(in) + use ed_misc_coms , only : ibigleaf ! ! intent(in) implicit none !----- Arguments. ----------------------------------------------------------------------! @@ -521,8 +722,16 @@ subroutine seed_dispersal(cpoly,late_spring) if (phenology(donpft) /= 2 .or. late_spring) then nseedling = donpatch%nplant(donco) * donpatch%bseeds(donco) & * (1.0 - seedling_mortality(donpft)) - nseed_stays = nseedling * (1.0 - nonlocal_dispersal(donpft)) - nseed_maygo = nseedling * nonlocal_dispersal(donpft) + select case (ibigleaf) + case (0) + nseed_stays = nseedling * (1.0 - nonlocal_dispersal(donpft)) + nseed_maygo = nseedling * nonlocal_dispersal(donpft) + case (1) + !---- if bigleaf cannot disperse seedlings to other patches ----------! + nseed_stays = nseedling + nseed_maygo = 0. + end select + else !----- Not a good time for reproduction. No seedlings. -----------------! nseedling = 0. @@ -542,7 +751,7 @@ subroutine seed_dispersal(cpoly,late_spring) ! this patch and site so the total carbon is preserved. ! !------------------------------------------------------------------------! csite%repro(donpft,recpa) = csite%repro(donpft,recpa) & - + nseed_maygo * csite%area(recpa) + + nseed_maygo * csite%area(donpa) !------------------------------------------------------------------------! @@ -565,7 +774,7 @@ subroutine seed_dispersal(cpoly,late_spring) end do siteloop1 !------------------------------------------------------------------------------------! - case (2) + case (2,3) !------------------------------------------------------------------------------------! ! Seeds are dispersed amongst patches that belong to the same polygon. They are ! @@ -593,8 +802,16 @@ subroutine seed_dispersal(cpoly,late_spring) if (phenology(donpft) /= 2 .or. late_spring) then nseedling = donpatch%nplant(donco) * donpatch%bseeds(donco) & * (1.0 - seedling_mortality(donpft)) - nseed_stays = nseedling * (1.0 - nonlocal_dispersal(donpft)) - nseed_maygo = nseedling * nonlocal_dispersal(donpft) + + select case (ibigleaf) + case (0) + nseed_stays = nseedling * (1.0 - nonlocal_dispersal(donpft)) + nseed_maygo = nseedling * nonlocal_dispersal(donpft) + case (1) + !---- if bigleaf cannot disperse seedlings to other patches ----------! + nseed_stays = nseedling + nseed_maygo = 0. + end select else !----- Not a good time for reproduction. No seedlings. -----------------! nseedling = 0. @@ -617,8 +834,8 @@ subroutine seed_dispersal(cpoly,late_spring) ! preserved. ! !---------------------------------------------------------------------! recsite%repro(donpft,recpa) = recsite%repro(donpft,recpa) & - + nseed_maygo * recsite%area(recpa) & - * cpoly%area(recsi) + + nseed_maygo * recsite%area(donpa) & + * cpoly%area(donsi) !---------------------------------------------------------------------! @@ -628,7 +845,7 @@ subroutine seed_dispersal(cpoly,late_spring) !---------------------------------------------------------------------! if (recpa == donpa .and. recsi == donsi) then recsite%repro(donpft,recpa) = recsite%repro(donpft,recpa) & - + nseed_stays + + nseed_stays end if !---------------------------------------------------------------------! diff --git a/ED/src/dynamics/rk4_derivs.F90 b/ED/src/dynamics/rk4_derivs.F90 index bae5fb018..f0d0315e5 100644 --- a/ED/src/dynamics/rk4_derivs.F90 +++ b/ED/src/dynamics/rk4_derivs.F90 @@ -7,14 +7,12 @@ ! whereas in LEAF-3 the actual step is done at once. This derivative will be used for the ! ! Runge-Kutta integration step. ! !------------------------------------------------------------------------------------------! -subroutine leaf_derivs(initp,dinitp,csite,ipa) +subroutine leaf_derivs(initp,dinitp,csite,ipa,dt) use rk4_coms , only : rk4site & ! intent(in) , rk4patchtype ! ! structure use ed_state_vars , only : sitetype & ! structure , polygontype ! ! structure - use consts_coms , only : cp8 & ! intent(in) - , cpi8 ! ! intent(in) use grid_coms , only : nzg & ! intent(in) , nzs ! ! intent(in) implicit none @@ -23,6 +21,8 @@ subroutine leaf_derivs(initp,dinitp,csite,ipa) type(rk4patchtype) , target :: dinitp ! Structure with RK4 derivatives type(sitetype) , target :: csite ! This site (with previous values); integer , intent(in) :: ipa ! Patch ID + real(kind=8) , intent(in) :: dt ! Current time step if euler/hybrid + ! this will be forced negative if otherwise !---------------------------------------------------------------------------------------! !---------------------------------------------------------------------------------------! @@ -33,9 +33,10 @@ subroutine leaf_derivs(initp,dinitp,csite,ipa) !------------------------------------------------------------------------------------! ! Subroutine that computes the canopy and leaf fluxes. ! !------------------------------------------------------------------------------------! - subroutine leaftw_derivs(mzg,mzs,initp,dinitp,csite,ipa) + subroutine leaftw_derivs(mzg,mzs,initp,dinitp,csite,ipa,dt) use rk4_coms , only : rk4patchtype ! ! structure - use ed_state_vars , only : sitetype,polygontype ! ! structure + use ed_state_vars , only : sitetype & ! structure + , polygontype ! ! structure implicit none !----- Arguments -----------------------------------------------------------------! type(rk4patchtype) , target :: initp ! RK4 structure, intermediate step @@ -44,6 +45,7 @@ subroutine leaftw_derivs(mzg,mzs,initp,dinitp,csite,ipa) integer , intent(in) :: ipa ! Current patch ID integer , intent(in) :: mzg ! Number of ground layers integer , intent(in) :: mzs ! Number of snow/ponding layers + real(kind=8) , intent(in) :: dt end subroutine leaftw_derivs !------------------------------------------------------------------------------------! end interface @@ -54,9 +56,12 @@ end subroutine leaftw_derivs dinitp%ebudget_storage = 0.d0 dinitp%wbudget_storage = 0.d0 dinitp%co2budget_storage = 0.d0 + !---------------------------------------------------------------------------------------! + - !----- Finding the derivatives. --------------------------------------------------------! - call leaftw_derivs(nzg,nzs,initp,dinitp,csite,ipa) + !----- Find the derivatives. -----------------------------------------------------------! + call leaftw_derivs(nzg,nzs,initp,dinitp,csite,ipa,dt) + !---------------------------------------------------------------------------------------! return end subroutine leaf_derivs @@ -70,12 +75,11 @@ end subroutine leaf_derivs !==========================================================================================! !==========================================================================================! -subroutine leaftw_derivs(mzg,mzs,initp,dinitp,csite,ipa) +subroutine leaftw_derivs(mzg,mzs,initp,dinitp,csite,ipa,dt) use ed_max_dims , only : nzgmax & ! intent(in) , nzsmax ! ! intent(in) - use consts_coms , only : alvl8 & ! intent(in) - , cliqvlme8 & ! intent(in) - , tsupercool8 & ! intent(in) + use consts_coms , only : cliq8 & ! intent(in) + , cph2o8 & ! intent(in) , wdns8 & ! intent(in) , wdnsi8 & ! intent(in) , lnexp_min8 ! ! intent(in) @@ -105,7 +109,7 @@ subroutine leaftw_derivs(mzg,mzs,initp,dinitp,csite,ipa) use ed_state_vars , only : sitetype & ! structure , patchtype & ! structure , polygontype ! ! structure - use therm_lib8 , only : qtk8 ! ! subroutine + use therm_lib8 , only : tl2uint8 ! ! functions use physiology_coms , only : h2o_plant_lim ! ! intent(in) implicit none !----- Arguments -----------------------------------------------------------------------! @@ -115,7 +119,10 @@ subroutine leaftw_derivs(mzg,mzs,initp,dinitp,csite,ipa) integer , intent(in) :: ipa ! Current patch number integer , intent(in) :: mzg ! Number of ground layers integer , intent(in) :: mzs ! Number of snow/ponding layers + real(kind=8) , intent(in) :: dt ! Timestep !----- Local variables -----------------------------------------------------------------! + type(patchtype) , pointer :: cpatch ! Current patch + integer :: ico ! Cohort counter integer :: k ! Level counter integer :: k1 ! Level counter integer :: k2 ! Level counter @@ -141,9 +148,14 @@ subroutine leaftw_derivs(mzg,mzs,initp,dinitp,csite,ipa) real(kind=8) :: wilting_factor ! Wilting factor real(kind=8) :: ext_weight ! Layer weight for transpiration real(kind=8) :: wgpmid ! Soil in between layers - real(kind=8) :: tloss ! Transpired water loss real(kind=8) :: wloss ! Water loss due to transpiration - real(kind=8) :: qwloss ! Energy loss due to transpiration + real(kind=8) :: wvlmeloss ! Water loss due to transpiration + real(kind=8) :: wloss_tot ! Total water loss amongst cohorts + real(kind=8) :: wvlmeloss_tot ! Total water loss amongst cohorts + real(kind=8) :: qloss ! Energy loss due to transpiration + real(kind=8) :: qvlmeloss ! Energy loss due to transpiration + real(kind=8) :: qloss_tot ! Total energy loss amongst cohorts + real(kind=8) :: qvlmeloss_tot ! Total energy loss amongst cohorts real(kind=8) :: dqwt ! Energy adjustment aux. variable real(kind=8) :: fracliq ! Fraction of liquid water real(kind=8) :: tempk ! Temperature @@ -170,7 +182,7 @@ subroutine leaftw_derivs(mzg,mzs,initp,dinitp,csite,ipa) subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc & ,dewgndflx,qdewgndflx,ddewgndflx,throughfall_tot & ,qthroughfall_tot,dthroughfall_tot,wshed_tot,qwshed_tot & - ,dwshed_tot) + ,dwshed_tot,dt) use rk4_coms , only: rk4patchtype ! ! structure use ed_state_vars, only: sitetype & ! structure , patchtype & ! structure @@ -180,6 +192,7 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc type (sitetype) , target :: csite integer , intent(in) :: ipa integer , intent(in) :: mzg + real(kind=8) , intent(in) :: dt real(kind=8) , intent(out) :: hflxgc real(kind=8) , intent(out) :: wflxgc real(kind=8) , intent(out) :: qwflxgc @@ -197,13 +210,24 @@ end subroutine canopy_derivs_two #endif !---------------------------------------------------------------------------------------! + + !----- Set the pointer to the current patch. -------------------------------------------! + cpatch => csite%patch(ipa) + !---------------------------------------------------------------------------------------! + + !----- Copy the # of surface water/snow layers and bottom layer to aliases -------------! ksn = initp%nlev_sfcwater klsl = rk4site%lsl kben = klsl - 1 - + !---------------------------------------------------------------------------------------! + + !---- Flush auxiliary variables to zero. -----------------------------------------------! call zero_rk4_aux() + !---------------------------------------------------------------------------------------! + + !----- Make sure derivatives are flushed to zero. --------------------------------------! dinitp%soil_energy(:) = 0.0d0 @@ -401,7 +425,7 @@ end subroutine canopy_derivs_two !---------------------------------------------------------------------------------------! call canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,dewgnd,qdewgnd & ,ddewgnd,throughfall_tot,qthroughfall_tot,dthroughfall_tot & - ,wshed_tot,qwshed_tot,dwshed_tot) + ,wshed_tot,qwshed_tot,dwshed_tot,dt) !---------------------------------------------------------------------------------------! @@ -575,7 +599,7 @@ end subroutine canopy_derivs_two **(2.d0 * soil8(nsoil)%slbs + 3.d0) & * (rk4aux%psiplusz(mzg)-initp%virtual_water/2.d3) & !diff. in pot. * 5.d-1 * (initp%soil_fracliq(mzg)+ initp%virtual_fracliq) ! mean liquid fraction - qinfilt = infilt * cliqvlme8 * (initp%virtual_tempk - tsupercool8) + qinfilt = infilt * wdns8 * tl2uint8(initp%virtual_tempk,1.d0) !----- Adjust other rates accordingly -----------------------------------------! rk4aux%w_flux(mzg+1) = rk4aux%w_flux(mzg+1) + infilt rk4aux%qw_flux(mzg+1) = rk4aux%qw_flux(mzg+1)+ qinfilt @@ -593,7 +617,7 @@ end subroutine canopy_derivs_two **(2.d0 * soil8(nsoil)%slbs + 3.d0) & * (rk4aux%psiplusz(mzg) - surface_water/2.d0) & !difference in potentials * 5.d-1 * (initp%soil_fracliq(mzg) + initp%sfcwater_fracliq(1)) - qinfilt = infilt * cliqvlme8 * (initp%sfcwater_tempk(1) - tsupercool8) + qinfilt = infilt * wdns8 * tl2uint8(initp%sfcwater_tempk(1),1.d0) !----- Adjust other rates accordingly -----------------------------------------! rk4aux%w_flux(mzg+1) = rk4aux%w_flux(mzg+1) + infilt rk4aux%qw_flux(mzg+1) = rk4aux%qw_flux(mzg+1) + qinfilt @@ -653,8 +677,7 @@ end subroutine canopy_derivs_two rk4aux%w_flux(k) = 0.d0 end if !----- Only liquid water is allowed to flow, find qw_flux (W/m2) accordingly. -------! - rk4aux%qw_flux(k) = rk4aux%w_flux(k) * cliqvlme8 & - * (initp%soil_tempk(k) - tsupercool8) + rk4aux%qw_flux(k) = rk4aux%w_flux(k) * wdns8 * tl2uint8(initp%soil_tempk(k),1.d0) !----- Save the moisture flux in kg/m2/s. -------------------------------------------! if (k /= 1) dinitp%avg_smoist_gg(k-1) = rk4aux%w_flux(k) * wdns8 ! Diagnostic end do @@ -715,19 +738,48 @@ end subroutine canopy_derivs_two ! (tloss) to m3/m3/s (wloss). Also, find the internal energy loss ! ! (qwloss) associated with the water loss. Since plants can extract ! ! liquid water only, the internal energy is assumed to be entirely in ! - ! liquid phase. ! + ! liquid phase. Because the actual conversion from liquid phase to ! + ! vapour happens at the leaf level, the internal energy must stay with ! + ! the leaves so energy is preserved. ! !------------------------------------------------------------------------! - tloss = rk4aux%extracted_water(k1) * ext_weight - wloss = rk4aux%extracted_water(k1) * ext_weight * wdnsi8 * dslzi8(k2) - qwloss = wloss * cliqvlme8 * (initp%soil_tempk(k2) - tsupercool8) + wloss_tot = 0.d0 + qloss_tot = 0.d0 + wvlmeloss_tot = 0.d0 + qvlmeloss_tot = 0.d0 + do ico=1,cpatch%ncohorts + !----- Find the loss from this cohort. -------------------------------! + wloss = rk4aux%extracted_water(ico,k1) * ext_weight + qloss = wloss * tl2uint8(initp%soil_tempk(k2),1.d0) + wvlmeloss = wloss * wdnsi8 * dslzi8(k2) + qvlmeloss = qloss * dslzi8(k2) + !---------------------------------------------------------------------! + + + !---------------------------------------------------------------------! + ! Add the internal energy to the cohort. This energy will be ! + ! eventually lost to the canopy air space because of transpiration, ! + ! but we will do it in two steps so we ensure energy is conserved. ! + !---------------------------------------------------------------------! + dinitp%leaf_energy(ico) = dinitp%leaf_energy(ico) + qloss + dinitp%veg_energy(ico) = dinitp%veg_energy(ico) + qloss + initp%hflx_lrsti(ico) = initp%hflx_lrsti(ico) + qloss + !---------------------------------------------------------------------! + + !----- Integrate the total to be removed from this layer. ------------! + wloss_tot = wloss_tot + wloss + qloss_tot = qloss_tot + qloss + wvlmeloss_tot = wvlmeloss_tot + wvlmeloss + qvlmeloss_tot = qvlmeloss_tot + qvlmeloss + !---------------------------------------------------------------------! + end do !------------------------------------------------------------------------! !----- Update derivatives of water, energy, and transpiration. ----------! - dinitp%soil_water (k2) = dinitp%soil_water(k2) - wloss - dinitp%soil_energy (k2) = dinitp%soil_energy(k2) - qwloss - dinitp%avg_transloss(k2) = dinitp%avg_transloss(k2) - tloss + dinitp%soil_water (k2) = dinitp%soil_water(k2) - wvlmeloss_tot + dinitp%soil_energy (k2) = dinitp%soil_energy(k2) - qvlmeloss_tot + dinitp%avg_transloss(k2) = dinitp%avg_transloss(k2) - wloss_tot !------------------------------------------------------------------------! end if !---------------------------------------------------------------------------! @@ -755,7 +807,7 @@ end subroutine leaftw_derivs !==========================================================================================! subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,dewgndflx & ,qdewgndflx,ddewgndflx,throughfall_tot,qthroughfall_tot & - ,dthroughfall_tot,wshed_tot,qwshed_tot,dwshed_tot) + ,dthroughfall_tot,wshed_tot,qwshed_tot,dwshed_tot,dt) use rk4_coms , only : rk4patchtype & ! Structure , rk4site & ! intent(in) , rk4aux & ! intent(inout) @@ -765,8 +817,6 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de , effarea_heat & ! intent(in) , effarea_evap & ! intent(in) , effarea_transp & ! intent(in) - , zoveg & ! intent(in) - , zveg & ! intent(in) , wcapcan & ! intent(in) , wcapcani & ! intent(in) , hcapcani & ! intent(in) @@ -782,15 +832,9 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de use ed_state_vars , only : sitetype & ! Structure , patchtype & ! Structure , polygontype - use consts_coms , only : alvl8 & ! intent(in) - , cp8 & ! intent(in) - , cpi8 & ! intent(in) - , twothirds8 & ! intent(in) + use consts_coms , only : twothirds8 & ! intent(in) , day_sec8 & ! intent(in) , grav8 & ! intent(in) - , alvi8 & ! intent(in) - , alvl8 & ! intent(in) - , alli8 & ! intent(in) , umol_2_kgC8 & ! intent(in) , pi18 & ! intent(in) , halfpi8 & ! intent(in) @@ -800,15 +844,16 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de , wdnsi8 & ! intent(in) , fdnsi8 & ! intent(in) , t3ple8 & ! intent(in) - , tsupercool8 & ! intent(in) - , cice8 & ! intent(in) - , cliq8 & ! intent(in) + , cpdry8 & ! intent(in) + , cph2o8 & ! intent(in) , epi8 & ! intent(in) , huge_num8 ! ! intent(in) use soil_coms , only : soil8 & ! intent(in) , dslzi8 & ! intent(in) , dewmax ! ! intent(in) - use therm_lib8 , only : rslif8 ! ! function + use therm_lib8 , only : qslif8 & ! function + , tq2enthalpy8 & ! function + , tl2uint8 ! ! function use ed_misc_coms , only : dtlsm & ! intent(in) , fast_diagnostics ! ! intent(in) use canopy_struct_dynamics, only : vertical_vel_flux8 ! ! function @@ -833,6 +878,7 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de real(kind=8) , intent(out) :: wshed_tot ! Water shed from leaves real(kind=8) , intent(out) :: qwshed_tot ! Internal energy of water shed real(kind=8) , intent(out) :: dwshed_tot ! Depth of water shed + real(kind=8) , intent(in) :: dt ! Timestep if euler/hybrid !----- Local variables -----------------------------------------------------------------! type(patchtype) , pointer :: cpatch ! Current patch integer :: ico ! Current cohort ID @@ -847,7 +893,9 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de real(kind=8) :: eflxac ! Atm->canopy Eq. Pot. temp flux real(kind=8) :: wflxlc_try ! Intended flux leaf sfc -> canopy real(kind=8) :: wflxwc_try ! Intended flux wood sfc -> canopy - real(kind=8) :: c3lai ! Term for psi_open/psi_closed + real(kind=8) :: shv_gradient ! Term for psi_open/psi_closed + real(kind=8) :: gleaf_open ! Net leaf conductance (open) + real(kind=8) :: gleaf_closed ! Net leaf conductance (closed) real(kind=8) :: hflxlc ! Leaf->canopy heat flux real(kind=8) :: hflxwc ! Wood->canopy heat flux real(kind=8) :: rgnd ! @@ -893,11 +941,13 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de real(kind=8) :: qwflxlc ! Leaf -> CAS evaporation (energy) real(kind=8) :: qwflxwc ! Wood -> CAS evaporation (energy) real(kind=8) :: qtransp ! Transpiration (energy) - real(kind=8) :: water_demand ! - real(kind=8) :: water_supply ! real(kind=8) :: flux_area ! Area between canopy and plant + real(kind=8) :: a,b,c0 ! Temporary variables for solving + ! the CO2 ODE + real(kind=8) :: max_dwdt,dwdt ! Used for capping leaf evap !----- Functions -----------------------------------------------------------------------! - real , external :: sngloff + real(kind=4), external :: sngloff ! Safe dble 2 single precision + real(kind=4), external :: compute_netrad ! Net radiation. !---------------------------------------------------------------------------------------! @@ -911,11 +961,11 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de !---------------------------------------------------------------------------------------! ! Computing the fluxes from atmosphere to canopy. ! !---------------------------------------------------------------------------------------! - rho_ustar = initp%can_rhos * initp%ustar ! Aux. variable - hflxac = rho_ustar * initp%tstar * initp%can_exner ! Sensible Heat flux - eflxac = rho_ustar * initp%estar * cp8 * initp%can_temp ! Enthalpy flux - wflxac = rho_ustar * initp%qstar ! Water flux - cflxac = rho_ustar * initp%cstar * mmdryi8 ! CO2 flux [umol/m2/s] + rho_ustar = initp%can_rhos * initp%ustar ! Aux. variable + hflxac = rho_ustar * initp%tstar * initp%can_exner ! Sensible Heat flux + wflxac = rho_ustar * initp%qstar ! Water flux + eflxac = rho_ustar * initp%estar ! Enthalpy flux + cflxac = rho_ustar * initp%cstar * mmdryi8 ! CO2 flux [umol/m2/s] !---------------------------------------------------------------------------------------! @@ -958,6 +1008,8 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de qintercepted_max = 0.d0 dintercepted_max = 0.d0 end if + !---------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------! ! The first guess for through fall is the rainfall minus the maximum ! @@ -967,6 +1019,7 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de throughfall_tot = rk4site%pcpg - intercepted_max qthroughfall_tot = rk4site%qpcpg - qintercepted_max dthroughfall_tot = rk4site%dpcpg - dintercepted_max + !---------------------------------------------------------------------------------! else !----- No precipitation, nothing to be intercepted... ----------------------------! intercepted_max = 0.d0 @@ -975,7 +1028,9 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de throughfall_tot = 0.d0 qthroughfall_tot = 0.d0 dthroughfall_tot = 0.d0 + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! else !------------------------------------------------------------------------------------! @@ -1021,7 +1076,8 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de ! Both are defined as positive quantities. Sensible heat is defined by only one ! ! variable, hflxgc [J/m2/s], which can be either positive or negative. ! !---------------------------------------------------------------------------------------! - hflxgc = initp%ggnet * initp%can_rhos * cp8 * (initp%ground_temp - initp%can_temp) + hflxgc = initp%ggnet * initp%can_rhos & + * initp%can_cp * (initp%ground_temp - initp%can_temp) wflx = initp%ggnet * initp%can_rhos * (initp%ground_ssh - initp%can_shv ) !---------------------------------------------------------------------------------------! @@ -1041,7 +1097,7 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de ! density based on MCD suggestion on 11/16/2009. ! !------------------------------------------------------------------------------------! dewgndflx = - wflx - qdewgndflx = dewgndflx * (alvi8 - initp%ground_fliq * alli8) + qdewgndflx = dewgndflx * tq2enthalpy8(initp%ground_temp,1.d0,.true.) ddewgndflx = dewgndflx & * (initp%ground_fliq * wdnsi8 + (1.d0-initp%ground_fliq) * fdnsi8) !----- Set evaporation fluxes to zero. ----------------------------------------------! @@ -1075,7 +1131,7 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de qdewgndflx = 0.d0 ddewgndflx = 0.d0 wflxgc = wflx - qwflxgc = wflx * (alvi8 - initp%ground_fliq * alli8) + qwflxgc = wflx * tq2enthalpy8(initp%ground_temp,1.d0,.true.) !----- Set flux flag. ---------------------------------------------------------------! initp%flag_wflxgc = 3 @@ -1102,7 +1158,7 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de wflxgc = initp%ggnet * initp%can_rhos * (initp%ground_shv - initp%can_shv) & * ( 1.d0 / (1.d0 + initp%ggnet / initp%ggsoil) ) !----- Adjusting the flux accordingly to the surface fraction (no phase bias). ------! - qwflxgc = wflxgc * ( alvi8 - initp%ground_fliq * alli8) + qwflxgc = wflxgc * tq2enthalpy8(initp%ground_temp,1.d0,.true.) !----- Set condensation fluxes to zero. ---------------------------------------------! dewgndflx = 0.d0 qdewgndflx = 0.d0 @@ -1114,7 +1170,11 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de !---------------------------------------------------------------------------------------! - + !-----------------------------------------------------------------------! + ! The implicit solver needs to know the mass flux from ground to canopy + !-----------------------------------------------------------------------! + initp%wflxgc = wflxgc + !---------------------------------------------------------------------------------------! ! Loop over the cohorts in the patch. Calculate energy fluxes with surrounding ! @@ -1228,7 +1288,38 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de ! with water. ! !---------------------------------------------------------------------------! wflxlc = wflxlc_try * sigmaw - qwflxlc = wflxlc * (alvi8 - initp%leaf_fliq(ico) * alli8) + qwflxlc = wflxlc * tq2enthalpy8(initp%leaf_temp(ico),1.d0,.true.) + + + + !---------------------------------------------------------------------------! + ! This is called by the hybrid solver only. ! + !---------------------------------------------------------------------------! + if (dt>-8000.d0) then + + max_dwdt = initp%leaf_water(ico)/dt + + max_leaf_water = rk4leaf_maxwhc*initp%lai(ico) + + !------------------------------------------------------------------------! + ! If we ever have shedding, force wshed to cap out at that maximum ! + ! leaf water. Assume this process happens before evaporation. ! + !------------------------------------------------------------------------! + wshed = max(0.d0,( (initp%leaf_water(ico) + leaf_intercepted*dt) & + - max_leaf_water) / dt) + qwshed = wshed * tl2uint8(initp%leaf_temp(ico),initp%leaf_fliq(ico)) + dwshed = wshed * ( initp%leaf_fliq(ico) * wdnsi8 & + + (1.d0-initp%leaf_fliq(ico)) * fdnsi8) + !------------------------------------------------------------------------! + + + !----- Then constrain the amount that can be evaporated. ----------------! + wflxlc = min(wflxlc,max_dwdt+leaf_intercepted-wshed) + !------------------------------------------------------------------------! + end if + !---------------------------------------------------------------------------! + + !---------------------------------------------------------------------------! ! Transpiration, consider the one-sided leaf area rather than LAI, ! @@ -1237,16 +1328,20 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de ! first make sure that there is some water available for transpiration... ! !---------------------------------------------------------------------------! if (rk4aux%avail_h2o_int(kroot) > 0.d0 ) then - c3lai = effarea_transp(ipft) * initp%lai(ico) & - * (initp%lint_shv(ico) - initp%can_shv) * initp%leaf_gbw(ico) - - dinitp%psi_open(ico) = c3lai * initp%gsw_open(ico) & - / (initp%leaf_gbw(ico) + initp%gsw_open(ico)) - dinitp%psi_closed(ico) = c3lai * initp%gsw_closed(ico) & - / (initp%leaf_gbw(ico) + initp%gsw_closed(ico)) - - transp = initp%fs_open(ico) * dinitp%psi_open(ico) & - + (1.0d0 - initp%fs_open(ico)) * dinitp%psi_closed(ico) + gleaf_open = effarea_transp(ipft) & + * initp%leaf_gbw(ico) * initp%gsw_open(ico) & + / (initp%leaf_gbw(ico) + initp%gsw_open(ico) ) + gleaf_closed = effarea_transp(ipft) & + * initp%leaf_gbw(ico) * initp%gsw_closed(ico) & + / ( initp%leaf_gbw(ico) + initp%gsw_closed(ico) ) + shv_gradient = initp%lint_shv(ico) - initp%can_shv + + dinitp%psi_open (ico) = gleaf_open * shv_gradient + dinitp%psi_closed(ico) = gleaf_closed * shv_gradient + + transp = initp%lai(ico) * ( initp%fs_open(ico) * dinitp%psi_open(ico) & + + (1.0d0 - initp%fs_open(ico)) & + * dinitp%psi_closed(ico) ) else dinitp%psi_open(ico) = 0.d0 dinitp%psi_closed(ico) = 0.d0 @@ -1256,7 +1351,7 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de ! Only liquid water is transpired, thus this is always the condensation ! ! latent heat. ! !---------------------------------------------------------------------------! - qtransp = transp * alvl8 + qtransp = transp * tq2enthalpy8(initp%leaf_temp(ico),1.d0,.true.) !---------------------------------------------------------------------------! else @@ -1273,11 +1368,10 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de else !------------------------------------------------------------------------------! - ! Dew/frost formation. The deposition will conserve the liquid/ice ! - ! partition (or use the default if there is no water). ! + ! Dew/frost formation. ! !------------------------------------------------------------------------------! wflxlc = wflxlc_try - qwflxlc = wflxlc * (alvi8 - initp%leaf_fliq(ico)*alli8) + qwflxlc = wflxlc * tq2enthalpy8(initp%leaf_temp(ico),1.d0,.true.) transp = 0.0d0 qtransp = 0.0d0 dinitp%psi_open (ico) = 0.0d0 @@ -1287,9 +1381,12 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de !---------------------------------------------------------------------------------! + + + !----- We need to extract water from the soil equal to the transpiration. --------! - rk4aux%extracted_water(kroot) = rk4aux%extracted_water(kroot) + transp + rk4aux%extracted_water(ico,kroot) = rk4aux%extracted_water(ico,kroot) + transp !---------------------------------------------------------------------------------! @@ -1298,7 +1395,7 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de ! Calculate leaf-to-canopy sensible heat flux. Always consider both sides of ! ! leaves. ! !---------------------------------------------------------------------------------! - flux_area = effarea_heat * initp%lai(ico) ! + pi18 * initp%wai(ico) + flux_area = effarea_heat * initp%lai(ico) hflxlc = flux_area * initp%leaf_gbh(ico) & * (initp%leaf_temp(ico) - initp%can_temp) !---------------------------------------------------------------------------------! @@ -1338,6 +1435,11 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de !---------------------------------------------------------------------------------! + initp%wflxlc(ico) = wflxlc + initp%wflxtr(ico) = transp + initp%hflx_lrsti(ico) = initp%rshort_l(ico)+initp%rlong_l(ico) & + - qwshed+leaf_qintercepted + !---------------------------------------------------------------------------------! ! If the detailed output is tracked, then we save the fluxes for this cohort. ! @@ -1403,6 +1505,7 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de throughfall_tot = throughfall_tot + intercepted_max * initp%lai(ico) * taii qthroughfall_tot = qthroughfall_tot + qintercepted_max * initp%lai(ico) * taii dthroughfall_tot = dthroughfall_tot + dintercepted_max * initp%lai(ico) * taii + !---------------------------------------------------------------------------------! end if !------------------------------------------------------------------------------------! @@ -1432,6 +1535,7 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de !---------------------------------------------------------------------------------! min_wood_water = rk4leaf_drywhc * initp%wai(ico) max_wood_water = rk4leaf_maxwhc * initp%wai(ico) + !---------------------------------------------------------------------------------! !------ Calculate fraction of wood covered with water. ---------------------------! if (initp%wood_water(ico) > min_wood_water) then @@ -1447,8 +1551,7 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de ! frost formation must account the branches and stems as well. ! !---------------------------------------------------------------------------------! !----- Find the wood specific humidity. ------------------------------------------! - wood_shv = rslif8(initp%can_prss,initp%wood_temp(ico)) - wood_shv = wood_shv / (1.d0 + wood_shv) + wood_shv = qslif8(initp%can_prss,initp%wood_temp(ico)) !----- Evaporation/condensation "flux" -------------------------------------------! wflxwc_try = initp%wai(ico) * initp%wood_gbw(ico) * (wood_shv - initp%can_shv) !---------------------------------------------------------------------------------! @@ -1470,7 +1573,7 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de ! with water. ! !---------------------------------------------------------------------------! wflxwc = wflxwc_try * sigmaw - qwflxwc = wflxwc * (alvi8 - initp%wood_fliq(ico) * alli8) + qwflxwc = wflxwc * tq2enthalpy8(initp%wood_temp(ico),1.d0,.true.) !---------------------------------------------------------------------------! else @@ -1487,7 +1590,7 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de ! partition (or use the default if there is no water). ! !------------------------------------------------------------------------------! wflxwc = wflxwc_try - qwflxwc = wflxwc * (alvi8 - initp%wood_fliq(ico) * alli8) + qwflxwc = wflxwc * tq2enthalpy8(initp%wood_temp(ico),1.d0,.true.) !------------------------------------------------------------------------------! end if @@ -1537,7 +1640,9 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de + wood_qintercepted ! ! Intercepted water energy !---------------------------------------------------------------------------------! - + initp%wflxwc(ico) = wflxwc + initp%hflx_wrsti(ico) = initp%rshort_w(ico)+initp%rlong_w(ico) & + -qwshed+wood_qintercepted !---------------------------------------------------------------------------------! ! If the detailed output is tracked, then we save the fluxes for this cohort. ! @@ -1555,6 +1660,7 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de wflxwc_tot = wflxwc_tot + wflxwc qwflxwc_tot = qwflxwc_tot + qwflxwc hflxwc_tot = hflxwc_tot + hflxwc + !---------------------------------------------------------------------------------! !---------------------------------------------------------------------------------! ! Here we update the liquid/frozen water fluxes and their associated vari- ! @@ -1572,6 +1678,7 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de throughfall_tot = throughfall_tot + throughfall qthroughfall_tot = qthroughfall_tot + qthroughfall dthroughfall_tot = dthroughfall_tot + dthroughfall + !---------------------------------------------------------------------------------! else !---------------------------------------------------------------------------------! ! If there is not enough leaf biomass to safely solve the leaf energy and ! @@ -1599,6 +1706,7 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de throughfall_tot = throughfall_tot + intercepted_max * initp%wai(ico) * taii qthroughfall_tot = qthroughfall_tot + qintercepted_max * initp%wai(ico) * taii dthroughfall_tot = dthroughfall_tot + dintercepted_max * initp%wai(ico) * taii + !---------------------------------------------------------------------------------! end if !------------------------------------------------------------------------------------! @@ -1618,23 +1726,48 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de ! Update the log of potential temperature (entropy), water vapour specific mass, ! ! and CO2 mixing ratio of the canopy air space. ! ! wcapcan: can_rhos * can_depth (water capacity) ! - ! hcapcan: can_rhos * can_depth * cp8 * can_temp (entropy capacity times temperature) ! + ! hcapcan: can_rhos * can_depth * can_exner (entropy capacity times temperature) ! ! ccapcan: can_rhos * can_depth * mmdryi (carbon capacity) ! !---------------------------------------------------------------------------------------! - dinitp%can_lntheta = ( hflxgc + hflxlc_tot + hflxwc_tot + hflxac) * hcapcani - dinitp%can_shv = ( wflxgc - dewgndflx + wflxlc_tot & - + wflxwc_tot + transp_tot + wflxac) * wcapcani - dinitp%can_co2 = ( cflxgc + cflxlc_tot + cflxac) * ccapcani - !---------------------------------------------------------------------------------------! - + dinitp%can_enthalpy = ( hflxgc + hflxlc_tot + hflxwc_tot & + + qwflxgc - qdewgndflx + qwflxlc_tot + qwflxwc_tot + qtransp_tot & + + eflxac ) * hcapcani + dinitp%can_shv = ( wflxgc - dewgndflx + wflxlc_tot & + + wflxwc_tot + transp_tot + wflxac ) * wcapcani + dinitp%can_co2 = ( cflxgc + cflxlc_tot + cflxac ) * ccapcani + !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! + if (.false.) then + !if (dt>-8000.d0) then + + a = ( cflxgc + cflxlc_tot & + + initp%can_rhos*initp%ggbare*mmdryi8*rk4site%atm_co2) * ccapcani + + b = (initp%can_rhos*initp%ggbare*mmdryi8) * ccapcani + c0 = initp%can_co2 + + ! Calculate the effective derivative + ! dinitp%can_co2 = ((a/b) + (c0-(a/b))*exp(-b*dt) - c0)/dt + + ! Calculate the effective cflxac term + + cflxac = (initp%can_rhos*initp%ggbare*mmdryi8*ccapcani)/dt & + * (rk4site%atm_co2*dt - ((a/b)*dt - c0*exp(-b*dt)/b + & + c0/b + (a/b)*exp(-b*dt)/b - (a/b)/b )) + + dinitp%can_co2 = ( cflxgc + cflxlc_tot + cflxac) * ccapcani + end if + !---------------------------------------------------------------------------------------! + initp%wflxac = wflxac !---------------------------------------------------------------------------------------! ! Integrate diagnostic variables - These are not activated unless fast file-type ! ! outputs are selected. This will speed up the integrator. ! !---------------------------------------------------------------------------------------! - if (fast_diagnostics .or. print_detailed) then + if (fast_diagnostics .or. checkbudget .or. print_detailed) then dinitp%avg_carbon_ac = cflxac ! Carbon flx, Atmo->Canopy @@ -1704,9 +1837,11 @@ subroutine canopy_derivs_two(mzg,initp,dinitp,csite,ipa,hflxgc,wflxgc,qwflxgc,de dinitp%ebudget_loss2atm = - eflxac dinitp%wbudget_loss2atm = - wflxac dinitp%co2budget_storage = dinitp%co2budget_storage + cflxgc + cflxlc_tot + cflxac - dinitp%ebudget_storage = dinitp%ebudget_storage + eflxac & - + dinitp%avg_rshort_gnd + dinitp%avg_rlong_gnd - dinitp%wbudget_storage = dinitp%wbudget_storage + wflxac + dinitp%ebudget_netrad = dble(compute_netrad(csite,ipa)) + dinitp%ebudget_storage = dinitp%ebudget_storage + dinitp%ebudget_netrad & + + rk4site%qpcpg - dinitp%ebudget_loss2atm + dinitp%wbudget_storage = dinitp%wbudget_storage + rk4site%pcpg & + - dinitp%wbudget_loss2atm end if !---------------------------------------------------------------------------------------! diff --git a/ED/src/dynamics/rk4_driver.F90 b/ED/src/dynamics/rk4_driver.F90 index 688129911..c19f5a0be 100644 --- a/ED/src/dynamics/rk4_driver.F90 +++ b/ED/src/dynamics/rk4_driver.F90 @@ -25,8 +25,8 @@ subroutine rk4_timestep(cgrid,ifm) use met_driver_coms , only : met_driv_state ! ! structure use grid_coms , only : nzg & ! intent(in) , nzs ! ! intent(in) - use canopy_struct_dynamics , only : canopy_turbulence8 ! ! subroutine use ed_misc_coms , only : current_time ! ! intent(in) + use therm_lib , only : tq2enthalpy ! ! function implicit none !----------- Use MPI timing calls, need declarations --------------------------------! @@ -45,17 +45,21 @@ subroutine rk4_timestep(cgrid,ifm) integer :: iun integer :: nsteps real :: wcurr_loss2atm + real :: ecurr_netrad real :: ecurr_loss2atm real :: co2curr_loss2atm real :: wcurr_loss2drainage real :: ecurr_loss2drainage real :: wcurr_loss2runoff real :: ecurr_loss2runoff - real :: old_can_theiv + real :: ecurr_prsseffect + real :: old_can_enthalpy real :: old_can_shv real :: old_can_co2 real :: old_can_rhos real :: old_can_temp + real :: old_can_prss + real :: old_can_depth !----- Functions --------------------------------------------------------------------! real , external :: walltime !------------------------------------------------------------------------------------! @@ -117,11 +121,12 @@ subroutine rk4_timestep(cgrid,ifm) !----- Save the previous thermodynamic state. ------------------------------! - old_can_theiv = csite%can_theiv(ipa) - old_can_shv = csite%can_shv(ipa) - old_can_co2 = csite%can_co2(ipa) - old_can_rhos = csite%can_rhos(ipa) - old_can_temp = csite%can_temp(ipa) + old_can_shv = csite%can_shv (ipa) + old_can_co2 = csite%can_co2 (ipa) + old_can_rhos = csite%can_rhos (ipa) + old_can_temp = csite%can_temp (ipa) + old_can_prss = csite%can_prss (ipa) + old_can_enthalpy = tq2enthalpy(csite%can_temp(ipa),csite%can_shv(ipa),.true.) !---------------------------------------------------------------------------! @@ -129,23 +134,29 @@ subroutine rk4_timestep(cgrid,ifm) !---------------------------------------------------------------------------! ! Copy the meteorological variables to the rk4site structure. ! !---------------------------------------------------------------------------! - call copy_met_2_rk4site(nzg,cmet%vels,cmet%atm_theiv,cmet%atm_theta & - ,cmet%atm_tmp,cmet%atm_shv,cmet%atm_co2,cmet%geoht & - ,cmet%exner,cmet%pcpg,cmet%qpcpg,cmet%dpcpg & - ,cmet%prss,cmet%rshort,cmet%rlong,cmet%par_beam & - ,cmet%par_diffuse,cmet%nir_beam,cmet%nir_diffuse & - ,cmet%geoht,cpoly%lsl(isi),cpoly%ntext_soil(:,isi) & - ,cpoly%green_leaf_factor(:,isi) & - ,cgrid%lon(ipy),cgrid%lat(ipy),cgrid%cosz(ipy)) + call copy_met_2_rk4site(nzg,csite%can_theta(ipa),csite%can_shv(ipa) & + ,csite%can_depth(ipa),cmet%vels,cmet%atm_theiv & + ,cmet%atm_theta,cmet%atm_tmp,cmet%atm_shv & + ,cmet%atm_co2,cmet%geoht,cmet%exner,cmet%pcpg & + ,cmet%qpcpg,cmet%dpcpg,cmet%prss,cmet%rshort & + ,cmet%rlong,cmet%par_beam,cmet%par_diffuse & + ,cmet%nir_beam,cmet%nir_diffuse,cmet%geoht & + ,cpoly%lsl(isi),cpoly%ntext_soil(:,isi) & + ,cpoly%green_leaf_factor(:,isi),cgrid%lon(ipy) & + ,cgrid%lat(ipy),cgrid%cosz(ipy)) + !---------------------------------------------------------------------------! + !----- Compute current storage terms. --------------------------------------! call update_budget(csite,cpoly%lsl(isi),ipa,ipa) + !---------------------------------------------------------------------------! + !---------------------------------------------------------------------------! ! Set up the integration patch. ! !---------------------------------------------------------------------------! call copy_patch_init(csite,ipa,integration_buff%initp) - + !---------------------------------------------------------------------------! !----- Get photosynthesis, stomatal conductance, and transpiration. --------! @@ -153,25 +164,35 @@ subroutine rk4_timestep(cgrid,ifm) ,cpoly%ntext_soil(:,isi) & ,cpoly%leaf_aging_factor(:,isi) & ,cpoly%green_leaf_factor(:,isi)) + !---------------------------------------------------------------------------! + !----- Compute root and heterotrophic respiration. -------------------------! call soil_respiration(csite,ipa,nzg,cpoly%ntext_soil(:,isi)) + !---------------------------------------------------------------------------! + !---------------------------------------------------------------------------! ! Set up the integration patch. ! !---------------------------------------------------------------------------! call copy_patch_init_carbon(csite,ipa,integration_buff%initp) + !---------------------------------------------------------------------------! + !---------------------------------------------------------------------------! ! This is the driver for the integration process... ! !---------------------------------------------------------------------------! call integrate_patch_rk4(csite,integration_buff%initp,ipa,wcurr_loss2atm & - ,ecurr_loss2atm,co2curr_loss2atm & + ,ecurr_netrad,ecurr_loss2atm,co2curr_loss2atm & ,wcurr_loss2drainage,ecurr_loss2drainage & ,wcurr_loss2runoff,ecurr_loss2runoff,nsteps) + !---------------------------------------------------------------------------! + !----- Add the number of steps into the step counter. ----------------------! cgrid%workload(13,ipy) = cgrid%workload(13,ipy) + real(nsteps) + !---------------------------------------------------------------------------! + !---------------------------------------------------------------------------! ! Update the minimum monthly temperature, based on canopy temperature. ! @@ -179,17 +200,20 @@ subroutine rk4_timestep(cgrid,ifm) if (cpoly%site(isi)%can_temp(ipa) < cpoly%min_monthly_temp(isi)) then cpoly%min_monthly_temp(isi) = cpoly%site(isi)%can_temp(ipa) end if - + !---------------------------------------------------------------------------! + + !---------------------------------------------------------------------------! ! Compute the residuals. ! !---------------------------------------------------------------------------! call compute_budget(csite,cpoly%lsl(isi),cmet%pcpg,cmet%qpcpg,ipa & - ,wcurr_loss2atm,ecurr_loss2atm,co2curr_loss2atm & - ,wcurr_loss2drainage,ecurr_loss2drainage & - ,wcurr_loss2runoff,ecurr_loss2runoff,cpoly%area(isi) & - ,cgrid%cbudget_nep(ipy),old_can_theiv,old_can_shv & - ,old_can_co2,old_can_rhos,old_can_temp) - + ,wcurr_loss2atm,ecurr_netrad,ecurr_loss2atm & + ,co2curr_loss2atm,wcurr_loss2drainage & + ,ecurr_loss2drainage,wcurr_loss2runoff,ecurr_loss2runoff & + ,cpoly%area(isi),cgrid%cbudget_nep(ipy),old_can_enthalpy & + ,old_can_shv,old_can_co2,old_can_rhos,old_can_temp & + ,old_can_prss) + !---------------------------------------------------------------------------! end do patchloop end do siteloop @@ -209,18 +233,16 @@ end subroutine rk4_timestep !=======================================================================================! ! This subroutine will drive the integration process. ! !---------------------------------------------------------------------------------------! - subroutine integrate_patch_rk4(csite,initp,ipa,wcurr_loss2atm,ecurr_loss2atm & - ,co2curr_loss2atm,wcurr_loss2drainage,ecurr_loss2drainage & - ,wcurr_loss2runoff,ecurr_loss2runoff,nsteps) + subroutine integrate_patch_rk4(csite,initp,ipa,wcurr_loss2atm,ecurr_netrad & + ,ecurr_loss2atm,co2curr_loss2atm,wcurr_loss2drainage & + ,ecurr_loss2drainage,wcurr_loss2runoff,ecurr_loss2runoff & + ,nsteps) use ed_state_vars , only : sitetype & ! structure , patchtype ! ! structure use ed_misc_coms , only : dtlsm ! ! intent(in) use soil_coms , only : soil_rough & ! intent(in) , snow_rough ! ! intent(in) use canopy_air_coms , only : exar8 ! ! intent(in) - use consts_coms , only : vonk8 & ! intent(in) - , cp8 & ! intent(in) - , cpi8 ! ! intent(in) use rk4_coms , only : integration_vars & ! structure , rk4patchtype & ! structure , rk4site & ! intent(inout) @@ -236,6 +258,7 @@ subroutine integrate_patch_rk4(csite,initp,ipa,wcurr_loss2atm,ecurr_loss2atm type(rk4patchtype) , target :: initp integer , intent(in) :: ipa real , intent(out) :: wcurr_loss2atm + real , intent(out) :: ecurr_netrad real , intent(out) :: ecurr_loss2atm real , intent(out) :: co2curr_loss2atm real , intent(out) :: wcurr_loss2drainage @@ -293,9 +316,9 @@ subroutine integrate_patch_rk4(csite,initp,ipa,wcurr_loss2atm,ecurr_loss2atm !------------------------------------------------------------------------------------! ! Move the state variables from the integrated patch to the model patch. ! !------------------------------------------------------------------------------------! - call initp2modelp(tend-tbeg,initp,csite,ipa,wcurr_loss2atm,ecurr_loss2atm & - ,co2curr_loss2atm,wcurr_loss2drainage,ecurr_loss2drainage & - ,wcurr_loss2runoff,ecurr_loss2runoff) + call initp2modelp(tend-tbeg,initp,csite,ipa,wcurr_loss2atm,ecurr_netrad & + ,ecurr_loss2atm,co2curr_loss2atm,wcurr_loss2drainage & + ,ecurr_loss2drainage,wcurr_loss2runoff,ecurr_loss2runoff) return end subroutine integrate_patch_rk4 @@ -312,19 +335,21 @@ end subroutine integrate_patch_rk4 ! This subroutine will copy the variables from the integration buffer to the state ! ! patch and cohorts. ! !---------------------------------------------------------------------------------------! - subroutine initp2modelp(hdid,initp,csite,ipa,wbudget_loss2atm,ebudget_loss2atm & - ,co2budget_loss2atm,wbudget_loss2drainage,ebudget_loss2drainage & - ,wbudget_loss2runoff,ebudget_loss2runoff) + subroutine initp2modelp(hdid,initp,csite,ipa,wbudget_loss2atm,ebudget_netrad & + ,ebudget_loss2atm,co2budget_loss2atm,wbudget_loss2drainage & + ,ebudget_loss2drainage,wbudget_loss2runoff,ebudget_loss2runoff) use rk4_coms , only : rk4patchtype & ! structure , rk4site & ! intent(in) , rk4min_veg_temp & ! intent(in) , rk4max_veg_temp & ! intent(in) , tiny_offset & ! intent(in) - , checkbudget ! ! intent(in) + , checkbudget & ! intent(in) + , ibranch_thermo ! ! intent(in) use ed_state_vars , only : sitetype & ! structure , patchtype & ! structure , edgrid_g ! ! structure use consts_coms , only : day_sec & ! intent(in) + , t3ple & ! intent(in) , t3ple8 & ! intent(in) , wdns8 ! ! intent(in) use ed_misc_coms , only : fast_diagnostics ! ! intent(in) @@ -334,8 +359,10 @@ subroutine initp2modelp(hdid,initp,csite,ipa,wbudget_loss2atm,ebudget_loss2atm , slzt8 ! ! intent(in) use grid_coms , only : nzg & ! intent(in) , nzs ! ! intent(in) - use therm_lib , only : qwtk & ! subroutine - , rslif ! ! function + use therm_lib , only : thetaeiv & ! subroutine + , uextcm2tl & ! subroutine + , cmtl2uext & ! subroutine + , qslif ! ! function use phenology_coms , only : spot_phen ! ! intent(in) use allometry , only : h2crownbh ! ! function use disturb_coms , only : include_fire & ! intent(in) @@ -347,6 +374,7 @@ subroutine initp2modelp(hdid,initp,csite,ipa,wbudget_loss2atm,ebudget_loss2atm real(kind=8) , intent(in) :: hdid integer , intent(in) :: ipa real , intent(out) :: wbudget_loss2atm + real , intent(out) :: ebudget_netrad real , intent(out) :: ebudget_loss2atm real , intent(out) :: co2budget_loss2atm real , intent(out) :: wbudget_loss2drainage @@ -370,6 +398,7 @@ subroutine initp2modelp(hdid,initp,csite,ipa,wbudget_loss2atm,ebudget_loss2atm real(kind=8) :: gnd_water real(kind=8) :: psiplusz real(kind=8) :: mcheight + real(kind=4) :: can_rvap !----- Local contants ---------------------------------------------------------------! real , parameter :: tendays_sec=10.*day_sec !----- External function ------------------------------------------------------------! @@ -382,7 +411,6 @@ subroutine initp2modelp(hdid,initp,csite,ipa,wbudget_loss2atm,ebudget_loss2atm ! those in which this is not true. All floating point variables are converted back ! ! to single precision. ! !------------------------------------------------------------------------------------! - csite%can_theiv(ipa) = sngloff(initp%can_theiv ,tiny_offset) csite%can_theta(ipa) = sngloff(initp%can_theta ,tiny_offset) csite%can_prss(ipa) = sngloff(initp%can_prss ,tiny_offset) csite%can_temp(ipa) = sngloff(initp%can_temp ,tiny_offset) @@ -395,6 +423,21 @@ subroutine initp2modelp(hdid,initp,csite,ipa,wbudget_loss2atm,ebudget_loss2atm csite%snowfac(ipa) = sngloff(initp%snowfac ,tiny_offset) csite%total_sfcw_depth(ipa) = sngloff(initp%total_sfcw_depth,tiny_offset) + + + + + !------------------------------------------------------------------------------------! + ! Find the ice-vapour equivalent potential temperature. This is done outside the ! + ! integrator because it is an iterative method and currently we are not using it as ! + ! a prognostic variable. ! + !------------------------------------------------------------------------------------! + can_rvap = csite%can_shv(ipa) / ( 1.0 - csite%can_shv(ipa)) + csite%can_theiv(ipa) = thetaeiv(csite%can_theta (ipa), csite%can_prss(ipa) & + ,csite%can_temp (ipa), can_rvap & + ,can_rvap ) + !------------------------------------------------------------------------------------! + csite%ggbare(ipa) = sngloff(initp%ggbare ,tiny_offset) csite%ggveg (ipa) = sngloff(initp%ggveg ,tiny_offset) csite%ggnet (ipa) = sngloff(initp%ggnet ,tiny_offset) @@ -469,6 +512,7 @@ subroutine initp2modelp(hdid,initp,csite,ipa,wbudget_loss2atm,ebudget_loss2atm if(checkbudget) then co2budget_loss2atm = sngloff(initp%co2budget_loss2atm ,tiny_offset) + ebudget_netrad = sngloff(initp%ebudget_netrad ,tiny_offset) ebudget_loss2atm = sngloff(initp%ebudget_loss2atm ,tiny_offset) ebudget_loss2drainage = sngloff(initp%ebudget_loss2drainage,tiny_offset) ebudget_loss2runoff = sngloff(initp%ebudget_loss2runoff ,tiny_offset) @@ -477,6 +521,7 @@ subroutine initp2modelp(hdid,initp,csite,ipa,wbudget_loss2atm,ebudget_loss2atm wbudget_loss2runoff = sngloff(initp%wbudget_loss2runoff ,tiny_offset) else co2budget_loss2atm = 0. + ebudget_netrad = 0. ebudget_loss2atm = 0. ebudget_loss2drainage = 0. ebudget_loss2runoff = 0. @@ -508,10 +553,10 @@ subroutine initp2modelp(hdid,initp,csite,ipa,wbudget_loss2atm,ebudget_loss2atm end do !----- Find the bottommost layer to consider. ---------------------------------------! select case(include_fire) - case (0,2) - ka = k_fire_first case (1) ka = rk4site%lsl + case default + ka = k_fire_first end select !----- Add soil moisture. -----------------------------------------------------------! do k=ka,nzg @@ -556,6 +601,7 @@ subroutine initp2modelp(hdid,initp,csite,ipa,wbudget_loss2atm,ebudget_loss2atm cpatch => csite%patch(ipa) do ico = 1,cpatch%ncohorts available_water = 0.d0 + kroot = cpatch%krdepth(ico) do k = kroot, nzg nsoil = rk4site%ntext_soil(k) available_water = available_water & @@ -614,166 +660,490 @@ subroutine initp2modelp(hdid,initp,csite,ipa,wbudget_loss2atm,ebudget_loss2atm !------------------------------------------------------------------------------------! ! Cohort variables. Here we must check whether the cohort was really solved or ! - ! it was skipped after being flagged as "unsafe". Here the reason why it was flag- ! - ! ged as such matters. ! + ! it was skipped after being flagged as "unsafe". In case the cohort was skipped, ! + ! we must check whether it was because it was too small or because it was buried in ! + ! snow. ! !------------------------------------------------------------------------------------! do ico = 1,cpatch%ncohorts - !---------------------------------------------------------------------------------! - ! LEAVES ! - !---------------------------------------------------------------------------------! - if (initp%leaf_resolvable(ico)) then + select case (ibranch_thermo) + case (1) !------------------------------------------------------------------------------! - ! Leaves were solved, update water and internal energy, and recalculate ! - ! the temperature and leaf intercellular specific humidity. The vegetation ! - ! dry heat capacity is constant within one time step, so it doesn't need to be ! - ! updated. ! + ! VEGETATION -- Leaf and branchwood were solved together, so they must remain ! + ! in thermal equilibrium. ! !------------------------------------------------------------------------------! - cpatch%leaf_water(ico) = sngloff(initp%leaf_water(ico) , tiny_offset) - cpatch%leaf_energy(ico) = sngloff(initp%leaf_energy(ico), tiny_offset) - call qwtk(cpatch%leaf_energy(ico),cpatch%leaf_water(ico),cpatch%leaf_hcap(ico) & - ,cpatch%leaf_temp(ico),cpatch%leaf_fliq(ico)) + if (initp%veg_resolvable(ico)) then - !------------------------------------------------------------------------------! - ! The intercellular specific humidity is always assumed to be at ! - ! saturation for a given temperature. Find the saturation mixing ratio, then ! - ! convert it to specific humidity. ! - !------------------------------------------------------------------------------! - cpatch%lint_shv(ico) = rslif(csite%can_prss(ipa),cpatch%leaf_temp(ico)) - cpatch%lint_shv(ico) = cpatch%lint_shv(ico) / (1. + cpatch%lint_shv(ico)) - !----- Convert the wind. ------------------------------------------------------! - cpatch%veg_wind(ico) = sngloff(initp%veg_wind(ico),tiny_offset) - !------------------------------------------------------------------------------! + !---------------------------------------------------------------------------! + ! Copy vegetation wind. ! + !---------------------------------------------------------------------------! + cpatch%veg_wind(ico) = sngloff(initp%veg_wind(ico),tiny_offset) + !---------------------------------------------------------------------------! - !------------------------------------------------------------------------------! - ! Copy the conductances. ! - !------------------------------------------------------------------------------! - cpatch%leaf_gbh (ico) = sngloff(initp%leaf_gbh (ico), tiny_offset) - cpatch%leaf_gbw (ico) = sngloff(initp%leaf_gbw (ico), tiny_offset) - !------------------------------------------------------------------------------! + !---------------------------------------------------------------------------! + ! LEAVES. It is always safe to copy internal energy and standing water, ! + ! but we must check whether leaves were truly resolved or not ! + ! before copying the other variables. ! + !---------------------------------------------------------------------------! + cpatch%leaf_water (ico) = sngloff(initp%leaf_water (ico) , tiny_offset) + cpatch%leaf_energy(ico) = sngloff(initp%leaf_energy(ico) , tiny_offset) + + + if (initp%leaf_resolvable(ico)) then + !------------------------------------------------------------------------! + ! Leaves were solved, find the temperature and liquid fraction from ! + ! internal energy. ! + !------------------------------------------------------------------------! + call uextcm2tl(cpatch%leaf_energy(ico),cpatch%leaf_water(ico) & + ,cpatch%leaf_hcap(ico),cpatch%leaf_temp(ico) & + ,cpatch%leaf_fliq(ico)) + !------------------------------------------------------------------------! + + + !------------------------------------------------------------------------! + ! The intercellular specific humidity is always assumed to be at ! + ! saturation for a given temperature. Find the saturation mixing ratio, ! + ! then convert it to specific humidity. ! + !------------------------------------------------------------------------! + cpatch%lint_shv(ico) = qslif(csite%can_prss(ipa),cpatch%leaf_temp(ico)) + !------------------------------------------------------------------------! + + + !------------------------------------------------------------------------! + ! Copy the conductances. ! + !------------------------------------------------------------------------! + cpatch%leaf_gbh(ico) = sngloff(initp%leaf_gbh(ico), tiny_offset) + cpatch%leaf_gbw(ico) = sngloff(initp%leaf_gbw(ico), tiny_offset) + !------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------! + ! Divide the values of water demand by the time step to obtain the ! + ! average value over the past hdid period. ! + !------------------------------------------------------------------------! + cpatch%psi_open (ico) = sngloff(initp%psi_open (ico),tiny_offset) & + / sngl(hdid) + cpatch%psi_closed(ico) = sngloff(initp%psi_closed(ico),tiny_offset) & + / sngl(hdid) + !------------------------------------------------------------------------! + else + !------------------------------------------------------------------------! + ! We solved leaf and branchwood together, the combined pool was re- ! + ! solvable but leaves weren't. We copy the leaf temperature and liquid ! + ! fraction from the integrator, so they remain in thermal equilibrium ! + ! with branchwood. ! + !------------------------------------------------------------------------! + cpatch%leaf_temp(ico) = sngloff(initp%leaf_temp(ico) , tiny_offset) + cpatch%leaf_fliq(ico) = sngloff(initp%leaf_fliq(ico) , tiny_offset) + !------------------------------------------------------------------------! + + + !------------------------------------------------------------------------! + ! The intercellular specific humidity is always assumed to be at ! + ! saturation for a given temperature. Find the saturation mixing ratio, ! + ! then convert it to specific humidity. ! + !------------------------------------------------------------------------! + cpatch%lint_shv(ico) = qslif(csite%can_prss(ipa),cpatch%leaf_temp(ico)) + !------------------------------------------------------------------------! + + !----- Set water demand and conductances to zero. -----------------------! + cpatch%psi_open (ico) = 0.0 + cpatch%psi_closed(ico) = 0.0 + cpatch%leaf_gbh (ico) = 0.0 + cpatch%leaf_gbw (ico) = 0.0 + !------------------------------------------------------------------------! + end if + !---------------------------------------------------------------------------! - !------------------------------------------------------------------------------! - ! Divide the values of water demand by the time step to obtain the average ! - ! value over the past hdid period. ! - !------------------------------------------------------------------------------! - cpatch%psi_open (ico) = sngloff(initp%psi_open (ico),tiny_offset) / sngl(hdid) - cpatch%psi_closed(ico) = sngloff(initp%psi_closed(ico),tiny_offset) / sngl(hdid) + !---------------------------------------------------------------------------! + ! BRANCHES. It is always safe to copy internal energy and standing ! + ! water, but we must check whether branches were truly ! + ! resolved or not before copying the other variables. ! + !---------------------------------------------------------------------------! + cpatch%wood_water (ico) = sngloff(initp%wood_water (ico) , tiny_offset) + cpatch%wood_energy(ico) = sngloff(initp%wood_energy(ico) , tiny_offset) + if (initp%wood_resolvable(ico)) then + !------------------------------------------------------------------------! + ! Branches were solved, find the temperature and liquid fraction from ! + ! internal energy. ! + !------------------------------------------------------------------------! + call uextcm2tl(cpatch%wood_energy(ico),cpatch%wood_water(ico) & + ,cpatch%wood_hcap(ico),cpatch%wood_temp(ico) & + ,cpatch%wood_fliq(ico)) + !------------------------------------------------------------------------! + + + !------------------------------------------------------------------------! + ! Copy the conductances. ! + !------------------------------------------------------------------------! + cpatch%wood_gbh(ico) = sngloff(initp%wood_gbh(ico), tiny_offset) + cpatch%wood_gbw(ico) = sngloff(initp%wood_gbw(ico), tiny_offset) + !------------------------------------------------------------------------! + else + !------------------------------------------------------------------------! + ! We solved leaf and branchwood together, the combined pool was re- ! + ! solvable but leaves weren't. We copy the leaf temperature and liquid ! + ! fraction from the integrator, so they remain in thermal equilibrium ! + ! with branchwood. ! + !------------------------------------------------------------------------! + cpatch%wood_temp(ico) = sngloff(initp%wood_temp(ico) , tiny_offset) + cpatch%wood_fliq(ico) = sngloff(initp%wood_fliq(ico) , tiny_offset) + !------------------------------------------------------------------------! + + + !----- Set the conductances to zero. ------------------------------------! + cpatch%wood_gbh(ico) = 0.0 + cpatch%wood_gbw(ico) = 0.0 + !------------------------------------------------------------------------! + end if + !---------------------------------------------------------------------------! + elseif (cpatch%hite(ico) <= csite%total_sfcw_depth(ipa)) then + !---------------------------------------------------------------------------! + ! For plants buried in snow, fix the leaf and branch temperatures to the ! + ! snow temperature of the layer that is the closest to the cohort top. ! + !---------------------------------------------------------------------------! + kclosest = 1 + do k = csite%nlev_sfcwater(ipa), 1, -1 + if (sum(csite%sfcwater_depth(1:k,ipa)) > cpatch%hite(ico)) kclosest = k + end do + !---------------------------------------------------------------------------! - elseif (cpatch%hite(ico) <= csite%total_sfcw_depth(ipa)) then - !------------------------------------------------------------------------------! - ! For plants buried in snow, fix the leaf temperature to the snow temper- ! - ! ature of the layer that is the closest to the leaves. ! + + cpatch%leaf_temp(ico) = csite%sfcwater_tempk(kclosest,ipa) + cpatch%wood_temp(ico) = cpatch%leaf_temp(ico) + + if (cpatch%leaf_temp(ico) == t3ple) then + cpatch%leaf_fliq(ico) = 0.5 + cpatch%wood_fliq(ico) = 0.5 + elseif (cpatch%leaf_temp(ico) > t3ple) then + cpatch%leaf_fliq(ico) = 1.0 + cpatch%wood_fliq(ico) = 1.0 + else + cpatch%leaf_fliq(ico) = 0.0 + cpatch%wood_fliq(ico) = 0.0 + end if + cpatch%leaf_water(ico) = 0. + cpatch%wood_water(ico) = 0. + + !---------------------------------------------------------------------------! + ! Find the internal energy diagnostically... ! + !---------------------------------------------------------------------------! + cpatch%leaf_energy(ico) = cmtl2uext( cpatch%leaf_hcap (ico) & + , cpatch%leaf_water(ico) & + , cpatch%leaf_temp (ico) & + , cpatch%leaf_fliq (ico) ) + cpatch%wood_energy(ico) = cmtl2uext( cpatch%wood_hcap (ico) & + , cpatch%wood_water(ico) & + , cpatch%wood_temp (ico) & + , cpatch%wood_fliq (ico) ) + !---------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------! + ! The intercellular specific humidity is always assumed to be at ! + ! saturation for a given temperature. Find the saturation mixing ratio, ! + ! then convert it to specific humidity. ! + !---------------------------------------------------------------------------! + cpatch%lint_shv(ico) = qslif(csite%can_prss(ipa),cpatch%leaf_temp(ico)) + !----- Copy the meteorological wind to here. -------------------------------! + cpatch%veg_wind(ico) = sngloff(rk4site%vels, tiny_offset) + !----- Set water demand and conductances to zero. --------------------------! + cpatch%psi_open (ico) = 0.0 + cpatch%psi_closed(ico) = 0.0 + cpatch%leaf_gbh (ico) = 0.0 + cpatch%leaf_gbw (ico) = 0.0 + cpatch%wood_gbh (ico) = 0.0 + cpatch%wood_gbw (ico) = 0.0 + !---------------------------------------------------------------------------! + else + !---------------------------------------------------------------------------! + ! For plants with minimal foliage or very sparse patches, fix the leaf ! + ! and branch temperatures to the canopy air space and force leaf and branch ! + ! intercepted water to be zero. ! + !---------------------------------------------------------------------------! + cpatch%leaf_temp(ico) = csite%can_temp(ipa) + cpatch%wood_temp(ico) = cpatch%leaf_temp(ico) + + if (cpatch%leaf_temp(ico) == t3ple) then + cpatch%leaf_fliq(ico) = 0.5 + cpatch%wood_fliq(ico) = 0.5 + elseif (cpatch%leaf_temp(ico) > t3ple) then + cpatch%leaf_fliq(ico) = 1.0 + cpatch%wood_fliq(ico) = 1.0 + else + cpatch%leaf_fliq(ico) = 0.0 + cpatch%wood_fliq(ico) = 0.0 + end if + cpatch%leaf_water(ico) = 0. + cpatch%wood_water(ico) = 0. + !---------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------! + ! Find the internal energy diagnostically... ! + !---------------------------------------------------------------------------! + cpatch%leaf_energy(ico) = cmtl2uext( cpatch%leaf_hcap (ico) & + , cpatch%leaf_water(ico) & + , cpatch%leaf_temp (ico) & + , cpatch%leaf_fliq (ico) ) + cpatch%wood_energy(ico) = cmtl2uext( cpatch%wood_hcap (ico) & + , cpatch%wood_water(ico) & + , cpatch%wood_temp (ico) & + , cpatch%wood_fliq (ico) ) + !---------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------! + ! The intercellular specific humidity is always assumed to be at ! + ! saturation for a given temperature. Find the saturation mixing ratio, ! + ! then convert it to specific humidity. ! + !---------------------------------------------------------------------------! + cpatch%lint_shv(ico) = qslif(csite%can_prss(ipa),cpatch%leaf_temp(ico)) + !----- Copy the meteorological wind to here. -------------------------------! + cpatch%veg_wind(ico) = sngloff(rk4site%vels, tiny_offset) + !----- Set water demand and conductances to zero. --------------------------! + cpatch%psi_open (ico) = 0.0 + cpatch%psi_closed(ico) = 0.0 + cpatch%leaf_gbh (ico) = 0.0 + cpatch%leaf_gbw (ico) = 0.0 + cpatch%wood_gbh (ico) = 0.0 + cpatch%wood_gbw (ico) = 0.0 + !---------------------------------------------------------------------------! + end if !------------------------------------------------------------------------------! - kclosest = 1 - do k = csite%nlev_sfcwater(ipa), 1, -1 - if (sum(csite%sfcwater_depth(1:k,ipa)) > cpatch%hite(ico)) kclosest = k - end do - cpatch%leaf_temp(ico) = csite%sfcwater_tempk(kclosest,ipa) - cpatch%leaf_fliq(ico) = 0. - cpatch%leaf_water(ico) = 0. - cpatch%leaf_energy(ico) = cpatch%leaf_hcap(ico) * cpatch%leaf_temp(ico) + case (0,2) !------------------------------------------------------------------------------! - ! The intercellular specific humidity is always assumed to be at ! - ! saturation for a given temperature. Find the saturation mixing ratio, then ! - ! convert it to specific humidity. ! + ! VEGETATION -- Leaf and branchwood were solved separately, so they are ! + ! analysed independently. ! !------------------------------------------------------------------------------! - cpatch%lint_shv(ico) = rslif(csite%can_prss(ipa),cpatch%leaf_temp(ico)) - cpatch%lint_shv(ico) = cpatch%lint_shv(ico) / (1. + cpatch%lint_shv(ico)) - !----- Copy the meteorological wind to here. ----------------------------------! - cpatch%veg_wind(ico) = sngloff(rk4site%vels, tiny_offset) - !----- Make water demand 0. ---------------------------------------------------! - cpatch%psi_open (ico) = 0.0 - cpatch%psi_closed(ico) = 0.0 - else - !------------------------------------------------------------------------------! - ! For plants with minimal foliage or very sparse patches, fix the leaf ! - ! temperature to the canopy air space and force leaf_water to be zero. ! - !------------------------------------------------------------------------------! - cpatch%leaf_temp(ico) = csite%can_temp(ipa) - cpatch%leaf_fliq(ico) = 0. - cpatch%leaf_water(ico) = 0. - cpatch%leaf_energy(ico) = cpatch%leaf_hcap(ico) * cpatch%leaf_temp(ico) + + !------------------------------------------------------------------------------! - ! The intercellular specific humidity is always assumed to be at ! - ! saturation for a given temperature. Find the saturation mixing ratio, then ! - ! convert it to specific humidity. ! + ! LEAVES ! !------------------------------------------------------------------------------! - cpatch%lint_shv(ico) = rslif(csite%can_prss(ipa),cpatch%leaf_temp(ico)) - cpatch%lint_shv(ico) = cpatch%lint_shv(ico) / (1. + cpatch%lint_shv(ico)) - !----- Copy the meteorological wind to here. ----------------------------------! - cpatch%veg_wind(ico) = sngloff(rk4site%vels, tiny_offset) - !----- Make water demand 0. ---------------------------------------------------! - cpatch%psi_open (ico) = 0.0 - cpatch%psi_closed(ico) = 0.0 - end if - !---------------------------------------------------------------------------------! + if (initp%leaf_resolvable(ico)) then + !---------------------------------------------------------------------------! + ! Leaves were solved, update water and internal energy, and re- ! + ! calculate the temperature and leaf intercellular specific humidity. The ! + ! vegetation dry heat capacity is constant within one time step, so it ! + ! doesn't need to be updated. ! + !---------------------------------------------------------------------------! + cpatch%leaf_water(ico) = sngloff(initp%leaf_water(ico) , tiny_offset) + cpatch%leaf_energy(ico) = sngloff(initp%leaf_energy(ico), tiny_offset) + call uextcm2tl(cpatch%leaf_energy(ico),cpatch%leaf_water(ico) & + ,cpatch%leaf_hcap(ico),cpatch%leaf_temp(ico) & + ,cpatch%leaf_fliq(ico)) + !---------------------------------------------------------------------------! + ! The intercellular specific humidity is always assumed to be at ! + ! saturation for a given temperature. Find the saturation mixing ratio, ! + ! then convert it to specific humidity. ! + !---------------------------------------------------------------------------! + cpatch%lint_shv(ico) = qslif(csite%can_prss(ipa),cpatch%leaf_temp(ico)) + !----- Convert the wind. ---------------------------------------------------! + cpatch%veg_wind(ico) = sngloff(initp%veg_wind(ico),tiny_offset) + !---------------------------------------------------------------------------! + !---------------------------------------------------------------------------! + ! Copy the conductances. ! + !---------------------------------------------------------------------------! + cpatch%leaf_gbh(ico) = sngloff(initp%leaf_gbh(ico), tiny_offset) + cpatch%leaf_gbw(ico) = sngloff(initp%leaf_gbw(ico), tiny_offset) + !---------------------------------------------------------------------------! - !---------------------------------------------------------------------------------! - ! WOOD ! - !---------------------------------------------------------------------------------! - if (initp%wood_resolvable(ico)) then - !------------------------------------------------------------------------------! - ! Wood was solved, update water and internal energy, and recalculate ! - ! the temperature. The wood dry heat capacity is constant within one time ! - ! step, so it doesn't need to be updated. ! - !------------------------------------------------------------------------------! - cpatch%wood_water(ico) = sngloff(initp%wood_water(ico) , tiny_offset) - cpatch%wood_energy(ico) = sngloff(initp%wood_energy(ico), tiny_offset) - call qwtk(cpatch%wood_energy(ico),cpatch%wood_water(ico),cpatch%wood_hcap(ico) & - ,cpatch%wood_temp(ico),cpatch%wood_fliq(ico)) - !----- Convert the wind. ------------------------------------------------------! - cpatch%veg_wind(ico) = sngloff(initp%veg_wind(ico),tiny_offset) - !------------------------------------------------------------------------------! + !---------------------------------------------------------------------------! + ! Divide the values of water demand by the time step to obtain the ! + ! average value over the past hdid period. ! + !---------------------------------------------------------------------------! + cpatch%psi_open (ico) = sngloff(initp%psi_open (ico),tiny_offset) & + / sngl(hdid) + cpatch%psi_closed(ico) = sngloff(initp%psi_closed(ico),tiny_offset) & + / sngl(hdid) + !---------------------------------------------------------------------------! + elseif (cpatch%hite(ico) <= csite%total_sfcw_depth(ipa)) then + !---------------------------------------------------------------------------! + ! For plants buried in snow, fix the leaf temperature to the snow ! + ! temperature of the layer that is the closest to the leaves. ! + !---------------------------------------------------------------------------! + kclosest = 1 + do k = csite%nlev_sfcwater(ipa), 1, -1 + if (sum(csite%sfcwater_depth(1:k,ipa)) > cpatch%hite(ico)) kclosest = k + end do + cpatch%leaf_temp(ico) = csite%sfcwater_tempk(kclosest,ipa) + if (cpatch%leaf_temp(ico) == t3ple) then + cpatch%leaf_fliq(ico) = 0.5 + elseif (cpatch%leaf_temp(ico) > t3ple) then + cpatch%leaf_fliq(ico) = 1.0 + else + cpatch%leaf_fliq(ico) = 0.0 + end if + cpatch%leaf_water(ico) = 0. + cpatch%leaf_energy(ico) = cmtl2uext( cpatch%leaf_hcap (ico) & + , cpatch%leaf_water(ico) & + , cpatch%leaf_temp (ico) & + , cpatch%leaf_fliq (ico) ) + !---------------------------------------------------------------------------! + ! The intercellular specific humidity is always assumed to be at ! + ! saturation for a given temperature. Find the saturation mixing ratio, ! + ! then convert it to specific humidity. ! + !---------------------------------------------------------------------------! + cpatch%lint_shv(ico) = qslif(csite%can_prss(ipa),cpatch%leaf_temp(ico)) + !----- Copy the meteorological wind to here. -------------------------------! + cpatch%veg_wind(ico) = sngloff(rk4site%vels, tiny_offset) + !----- Set water demand and conductances to zero. --------------------------! + cpatch%psi_open (ico) = 0.0 + cpatch%psi_closed(ico) = 0.0 + cpatch%leaf_gbh (ico) = 0.0 + cpatch%leaf_gbw (ico) = 0.0 + !---------------------------------------------------------------------------! - !------------------------------------------------------------------------------! - ! Copy the conductances. ! - !------------------------------------------------------------------------------! - cpatch%wood_gbh (ico) = sngloff(initp%wood_gbh (ico), tiny_offset) - cpatch%wood_gbw (ico) = sngloff(initp%wood_gbw (ico), tiny_offset) + else + !---------------------------------------------------------------------------! + ! For plants with minimal foliage or very sparse patches, fix the leaf ! + ! temperature to the canopy air space and force leaf_water to be zero. ! + !---------------------------------------------------------------------------! + cpatch%leaf_temp(ico) = csite%can_temp(ipa) + if (cpatch%leaf_temp(ico) == t3ple) then + cpatch%leaf_fliq(ico) = 0.5 + elseif (cpatch%leaf_temp(ico) > t3ple) then + cpatch%leaf_fliq(ico) = 1.0 + else + cpatch%leaf_fliq(ico) = 0.0 + end if + cpatch%leaf_water(ico) = 0. + cpatch%leaf_energy(ico) = cmtl2uext( cpatch%leaf_hcap (ico) & + , cpatch%leaf_water(ico) & + , cpatch%leaf_temp (ico) & + , cpatch%leaf_fliq (ico) ) + !---------------------------------------------------------------------------! + ! The intercellular specific humidity is always assumed to be at ! + ! saturation for a given temperature. Find the saturation mixing ratio, ! + ! then convert it to specific humidity. ! + !---------------------------------------------------------------------------! + cpatch%lint_shv (ico) = qslif(csite%can_prss(ipa),cpatch%leaf_temp(ico)) + !----- Copy the meteorological wind to here. -------------------------------! + cpatch%veg_wind (ico) = sngloff(rk4site%vels, tiny_offset) + !----- Set water demand and conductances to zero. --------------------------! + cpatch%psi_open (ico) = 0.0 + cpatch%psi_closed(ico) = 0.0 + cpatch%leaf_gbh (ico) = 0.0 + cpatch%leaf_gbw (ico) = 0.0 + !---------------------------------------------------------------------------! + end if !------------------------------------------------------------------------------! - elseif (cpatch%hite(ico) <= csite%total_sfcw_depth(ipa)) then - !------------------------------------------------------------------------------! - ! For plants buried in snow, fix the wood temperature to the snow temper- ! - ! ature of the layer that is the closest to the branches. ! - !------------------------------------------------------------------------------! - kclosest = 1 - do k = csite%nlev_sfcwater(ipa), 1, -1 - if (sum(csite%sfcwater_depth(1:k,ipa)) > cpatch%hite(ico)) kclosest = k - end do - cpatch%wood_temp(ico) = csite%sfcwater_tempk(kclosest,ipa) - cpatch%wood_fliq(ico) = 0. - cpatch%wood_water(ico) = 0. - cpatch%wood_energy(ico) = cpatch%wood_hcap(ico) * cpatch%wood_temp(ico) - !----- Copy the meteorological wind to here. ----------------------------------! - cpatch%veg_wind(ico) = sngloff(rk4site%vels, tiny_offset) - else + + !------------------------------------------------------------------------------! - ! For very sparse patches of for when wood thermodynamics is off, fix the ! - ! wood temperature to the canopy air space and force wood_water to be zero. ! + ! WOOD ! !------------------------------------------------------------------------------! - cpatch%wood_temp(ico) = csite%can_temp(ipa) - cpatch%wood_fliq(ico) = 0. - cpatch%wood_water(ico) = 0. - cpatch%wood_energy(ico) = cpatch%wood_hcap(ico) * cpatch%wood_temp(ico) + if (initp%wood_resolvable(ico)) then + !---------------------------------------------------------------------------! + ! Wood was solved, update water and internal energy, and recalculate ! + ! the temperature. The wood dry heat capacity is constant within one time ! + ! step, so it doesn't need to be updated. ! + !---------------------------------------------------------------------------! + cpatch%wood_water(ico) = sngloff(initp%wood_water(ico) , tiny_offset) + cpatch%wood_energy(ico) = sngloff(initp%wood_energy(ico), tiny_offset) + call uextcm2tl(cpatch%wood_energy(ico),cpatch%wood_water(ico) & + ,cpatch%wood_hcap(ico),cpatch%wood_temp(ico) & + ,cpatch%wood_fliq(ico)) + + !----- Convert the wind. ---------------------------------------------------! + cpatch%veg_wind(ico) = sngloff(initp%veg_wind(ico),tiny_offset) + !---------------------------------------------------------------------------! + + !---------------------------------------------------------------------------! + ! Copy the conductances. ! + !---------------------------------------------------------------------------! + cpatch%wood_gbh(ico) = sngloff(initp%wood_gbh(ico), tiny_offset) + cpatch%wood_gbw(ico) = sngloff(initp%wood_gbw(ico), tiny_offset) + !---------------------------------------------------------------------------! - !----- Copy the meteorological wind to here. ----------------------------------! - if (.not. cpatch%leaf_resolvable(ico)) then + elseif (cpatch%hite(ico) <= csite%total_sfcw_depth(ipa)) then + !---------------------------------------------------------------------------! + ! For plants buried in snow, fix the wood temperature to the snow ! + ! temperature of the layer that is the closest to the branches. ! + !---------------------------------------------------------------------------! + kclosest = 1 + do k = csite%nlev_sfcwater(ipa), 1, -1 + if (sum(csite%sfcwater_depth(1:k,ipa)) > cpatch%hite(ico)) kclosest = k + end do + cpatch%wood_temp(ico) = csite%sfcwater_tempk(kclosest,ipa) + if (cpatch%wood_temp(ico) == t3ple) then + cpatch%wood_fliq(ico) = 0.5 + elseif (cpatch%wood_temp(ico) > t3ple) then + cpatch%wood_fliq(ico) = 1.0 + else + cpatch%wood_fliq(ico) = 0.0 + end if + cpatch%wood_water(ico) = 0. + cpatch%wood_energy(ico) = cmtl2uext( cpatch%wood_hcap (ico) & + , cpatch%wood_water(ico) & + , cpatch%wood_temp (ico) & + , cpatch%wood_fliq (ico) ) + !---------------------------------------------------------------------------! + + !----- Copy the meteorological wind to here. -------------------------------! cpatch%veg_wind(ico) = sngloff(rk4site%vels, tiny_offset) + !---------------------------------------------------------------------------! + + + !----- Set the conductances to zero. ---------------------------------------! + cpatch%wood_gbh(ico) = 0.0 + cpatch%wood_gbw(ico) = 0.0 + !---------------------------------------------------------------------------! + + else + !---------------------------------------------------------------------------! + ! For very sparse patches of for when wood thermodynamics is off, fix ! + ! the wood temperature to the canopy air space and force wood_water to be ! + ! zero. ! + !---------------------------------------------------------------------------! + cpatch%wood_temp(ico) = csite%can_temp(ipa) + if (cpatch%wood_temp(ico) == t3ple) then + cpatch%wood_fliq(ico) = 0.5 + elseif (cpatch%wood_temp(ico) > t3ple) then + cpatch%wood_fliq(ico) = 1.0 + else + cpatch%wood_fliq(ico) = 0.0 + end if + cpatch%wood_water(ico) = 0. + cpatch%wood_energy(ico) = cmtl2uext( cpatch%wood_hcap (ico) & + , cpatch%wood_water(ico) & + , cpatch%wood_temp (ico) & + , cpatch%wood_fliq (ico) ) + + + !----- Set the conductances to zero. ---------------------------------------! + cpatch%wood_gbh(ico) = 0.0 + cpatch%wood_gbw(ico) = 0.0 + !---------------------------------------------------------------------------! + + + !----- Copy the meteorological wind to here. -------------------------------! + if (.not. cpatch%leaf_resolvable(ico)) then + cpatch%veg_wind(ico) = sngloff(rk4site%vels, tiny_offset) + end if + !---------------------------------------------------------------------------! end if - end if + !------------------------------------------------------------------------------! + end select + !---------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------! ! Final sanity check. This should be removed soon, since it should never ! diff --git a/ED/src/dynamics/rk4_integ_utils.f90 b/ED/src/dynamics/rk4_integ_utils.f90 index de48e4e08..4cbfda8c2 100644 --- a/ED/src/dynamics/rk4_integ_utils.f90 +++ b/ED/src/dynamics/rk4_integ_utils.f90 @@ -30,10 +30,8 @@ subroutine odeint(h1,csite,ipa,nsteps) , nzs ! ! intent(in) use soil_coms , only : dslz8 & ! intent(in) , runoff_time ! ! intent(in) - use consts_coms , only : cliq8 & ! intent(in) - , t3ple8 & ! intent(in) - , tsupercool8 & ! intent(in) - , wdnsi8 ! ! intent(in) + use consts_coms , only : wdnsi8 ! ! intent(in) + use therm_lib8 , only : tl2uint8 ! ! intent(in) implicit none !----- Arguments -----------------------------------------------------------------------! type(sitetype) , target :: csite ! Current site @@ -100,7 +98,7 @@ subroutine odeint(h1,csite,ipa,nsteps) timesteploop: do i=1,maxstp !----- Get initial derivatives ------------------------------------------------------! - call leaf_derivs(integration_buff%y,integration_buff%dydx,csite,ipa) + call leaf_derivs(integration_buff%y,integration_buff%dydx,csite,ipa,-9000.d0) !----- Get scalings used to determine stability -------------------------------------! call get_yscal(integration_buff%y, integration_buff%dydx,h,integration_buff%yscal & @@ -131,8 +129,7 @@ subroutine odeint(h1,csite,ipa,nsteps) * integration_buff%y%sfcwater_mass(ksn) & * (integration_buff%y%sfcwater_fracliq(ksn) - 1.d-1) / 9.d-1 - qwfree = wfreeb & - * cliq8 * (integration_buff%y%sfcwater_tempk(ksn) - tsupercool8 ) + qwfree = wfreeb * tl2uint8(integration_buff%y%sfcwater_tempk(ksn),1.d0) integration_buff%y%sfcwater_mass(ksn) = & integration_buff%y%sfcwater_mass(ksn) & @@ -142,7 +139,7 @@ subroutine odeint(h1,csite,ipa,nsteps) integration_buff%y%sfcwater_depth(ksn) & - wfreeb*wdnsi8 - !----- Recompute the energy removing runoff --------------------------------! + !----- Remove internal energy lost due to runoff. --------------------------! integration_buff%y%sfcwater_energy(ksn) = & integration_buff%y%sfcwater_energy(ksn) - qwfree @@ -218,19 +215,26 @@ end subroutine odeint ! is to ensure all variables are in double precision, so consistent with the buffer vari- ! ! ables. ! !------------------------------------------------------------------------------------------! -subroutine copy_met_2_rk4site(mzg,vels,atm_theiv,atm_theta,atm_tmp,atm_shv,atm_co2,zoff & - ,exner,pcpg,qpcpg,dpcpg,prss,rshort,rlong,par_beam & - ,par_diffuse,nir_beam,nir_diffuse,geoht,lsl,ntext_soil & - ,green_leaf_factor,lon,lat,cosz) +subroutine copy_met_2_rk4site(mzg,can_theta,can_shv,can_depth,vels,atm_theiv,atm_theta & + ,atm_tmp,atm_shv,atm_co2,zoff,exner,pcpg,qpcpg,dpcpg,prss & + ,rshort,rlong,par_beam,par_diffuse,nir_beam,nir_diffuse,geoht & + ,lsl,ntext_soil,green_leaf_factor,lon,lat,cosz) use ed_max_dims , only : n_pft ! ! intent(in) use rk4_coms , only : rk4site ! ! structure use canopy_air_coms, only : ubmin8 ! ! intent(in) use therm_lib8 , only : rehuil8 & ! function + , reducedpress8 & ! function + , tq2enthalpy8 & ! function + , press2exner8 & ! function + , extheta2temp8 & ! function , idealdenssh8 ! ! function implicit none !----- Arguments -----------------------------------------------------------------------! integer , intent(in) :: mzg integer , intent(in) :: lsl + real , intent(in) :: can_theta + real , intent(in) :: can_shv + real , intent(in) :: can_depth real , intent(in) :: vels real , intent(in) :: atm_theiv real , intent(in) :: atm_theta @@ -256,7 +260,12 @@ subroutine copy_met_2_rk4site(mzg,vels,atm_theiv,atm_theta,atm_tmp,atm_shv,atm_c real , intent(in) :: lat real , intent(in) :: cosz !----- Local variables. ----------------------------------------------------------------! - integer :: ipft + integer :: ipft + real(kind=8) :: can_theta8 + real(kind=8) :: can_shv8 + real(kind=8) :: can_depth8 + real(kind=8) :: can_prss8 + real(kind=8) :: can_exner8 !---------------------------------------------------------------------------------------! @@ -291,14 +300,34 @@ subroutine copy_met_2_rk4site(mzg,vels,atm_theiv,atm_theta,atm_tmp,atm_shv,atm_c !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! + ! Copy the canopy air space properties to double precision scratch variables. ! + !---------------------------------------------------------------------------------------! + can_theta8 = dble(can_theta) + can_shv8 = dble(can_shv ) + can_depth8 = dble(can_depth) + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! Find the pressure and Exner functions at the canopy depth, find the temperature ! + ! of the air above canopy at the canopy depth, and the specific enthalpy at that level. ! + !---------------------------------------------------------------------------------------! + can_prss8 = reducedpress8(rk4site%atm_prss,rk4site%atm_theta,rk4site%atm_shv & + ,rk4site%geoht,can_theta8,can_shv8,can_depth8) + can_exner8 = press2exner8 (can_prss8) + rk4site%atm_tmp_zcan = extheta2temp8(can_exner8,rk4site%atm_theta) + rk4site%atm_enthalpy = tq2enthalpy8 (rk4site%atm_tmp_zcan,rk4site%atm_shv,.true.) + !---------------------------------------------------------------------------------------! + + + !----- Find the other variables that require a little math. ----------------------------! - rk4site%vels = max(ubmin8,dble(vels)) - rk4site%atm_lntheta = log(rk4site%atm_theta) - rk4site%atm_rvap = rk4site%atm_shv / (1.d0 - rk4site%atm_shv) - rk4site%atm_rhv = rehuil8(rk4site%atm_prss,rk4site%atm_tmp & - ,rk4site%atm_rvap) - rk4site%atm_rhos = idealdenssh8(rk4site%atm_prss,rk4site%atm_tmp & - ,rk4site%atm_shv) + rk4site%vels = max(ubmin8,dble(vels)) + rk4site%atm_rhv = rehuil8(rk4site%atm_prss,rk4site%atm_tmp,rk4site%atm_shv,.true.) + rk4site%atm_rhos = idealdenssh8(rk4site%atm_prss,rk4site%atm_tmp,rk4site%atm_shv) !---------------------------------------------------------------------------------------! @@ -339,7 +368,7 @@ subroutine inc_rk4_patch(rkp, inc, fac, cpatch) integer :: k ! Counter !---------------------------------------------------------------------------------------! - rkp%can_lntheta = rkp%can_lntheta + fac * inc%can_lntheta + rkp%can_enthalpy = rkp%can_enthalpy + fac * inc%can_enthalpy rkp%can_shv = rkp%can_shv + fac * inc%can_shv rkp%can_co2 = rkp%can_co2 + fac * inc%can_co2 @@ -377,10 +406,10 @@ subroutine inc_rk4_patch(rkp, inc, fac, cpatch) rkp%psi_closed(ico) = rkp%psi_closed(ico) + fac * inc%psi_closed(ico) end do - if(checkbudget) then + if (checkbudget) then - rkp%co2budget_storage = rkp%co2budget_storage + fac * inc%co2budget_storage - rkp%co2budget_loss2atm = rkp%co2budget_loss2atm + fac * inc%co2budget_loss2atm + rkp%co2budget_storage = rkp%co2budget_storage + fac * inc%co2budget_storage + rkp%co2budget_loss2atm = rkp%co2budget_loss2atm + fac * inc%co2budget_loss2atm rkp%wbudget_storage = rkp%wbudget_storage + fac * inc%wbudget_storage rkp%wbudget_loss2atm = rkp%wbudget_loss2atm + fac * inc%wbudget_loss2atm @@ -388,6 +417,7 @@ subroutine inc_rk4_patch(rkp, inc, fac, cpatch) + fac * inc%wbudget_loss2drainage rkp%ebudget_storage = rkp%ebudget_storage + fac * inc%ebudget_storage + rkp%ebudget_netrad = rkp%ebudget_netrad + fac * inc%ebudget_netrad rkp%ebudget_loss2atm = rkp%ebudget_loss2atm + fac * inc%ebudget_loss2atm rkp%ebudget_loss2drainage = rkp%ebudget_loss2drainage & + fac * inc%ebudget_loss2drainage @@ -515,9 +545,7 @@ subroutine get_yscal(y,dy,htry,yscal,cpatch) , checkbudget ! ! intent(in) use grid_coms , only : nzg & ! intent(in) , nzs ! ! intent(in) - use consts_coms , only : cliq8 & ! intent(in) - , qliqt38 & ! intent(in) - , wdnsi8 ! ! intent(in) + use consts_coms , only : wdnsi8 ! ! intent(in) use soil_coms , only : isoilbc & ! intent(in) , dslzi8 ! ! intent(in) implicit none @@ -535,9 +563,9 @@ subroutine get_yscal(y,dy,htry,yscal,cpatch) integer :: ico ! Current cohort ID !---------------------------------------------------------------------------------------! - yscal%can_lntheta = abs(y%can_lntheta) + abs(dy%can_lntheta * htry) - yscal%can_shv = abs(y%can_shv ) + abs(dy%can_shv * htry) - yscal%can_co2 = abs(y%can_co2 ) + abs(dy%can_co2 * htry) + yscal%can_enthalpy = abs(y%can_enthalpy) + abs(dy%can_enthalpy * htry) + yscal%can_shv = abs(y%can_shv ) + abs(dy%can_shv * htry) + yscal%can_co2 = abs(y%can_co2 ) + abs(dy%can_co2 * htry) !---------------------------------------------------------------------------------------! ! We don't solve pressure prognostically, so the scale cannot be computed based on ! @@ -598,7 +626,7 @@ subroutine get_yscal(y,dy,htry,yscal,cpatch) yscal%sfcwater_mass (1) = abs(y%sfcwater_mass (1) ) & + abs(dy%sfcwater_mass (1) * htry) yscal%sfcwater_depth (1) = abs(y%sfcwater_depth (1) ) & - + abs(dy%sfcwater_energy(1) * htry) + + abs(dy%sfcwater_depth (1) * htry) yscal%sfcwater_energy(1) = huge_offset do k=2,nzs yscal%sfcwater_mass (k) = huge_offset @@ -632,7 +660,7 @@ subroutine get_yscal(y,dy,htry,yscal,cpatch) yscal%sfcwater_energy(k) = abs(y%sfcwater_energy (k) ) & + abs(dy%sfcwater_energy(k) * htry) yscal%sfcwater_depth (k) = abs(y%sfcwater_depth (k) ) & - + abs(dy%sfcwater_energy(k) * htry) + + abs(dy%sfcwater_depth (k) * htry) end do do k=y%nlev_sfcwater+1,nzs yscal%sfcwater_mass (k) = huge_offset @@ -719,7 +747,7 @@ subroutine get_yscal(y,dy,htry,yscal,cpatch) !----- Copy the logical tests. ---------------------------------------------------! yscal%leaf_resolvable(ico) = y%leaf_resolvable(ico) yscal%wood_resolvable(ico) = y%wood_resolvable(ico) - yscal%veg_resolvable(ico) = y%veg_resolvable(ico) + yscal%veg_resolvable (ico) = y%veg_resolvable(ico) !---------------------------------------------------------------------------------! @@ -730,7 +758,7 @@ subroutine get_yscal(y,dy,htry,yscal,cpatch) yscal%leaf_temp(ico) = abs( y%leaf_temp(ico)) yscal%leaf_water(ico) = max( abs(y%leaf_water(ico)) & + abs(dy%leaf_water(ico) * htry) & - , rk4leaf_drywhc * y%lai(ico)) + , rk4leaf_drywhc * y%lai(ico)) else yscal%leaf_water(ico) = huge_offset yscal%leaf_energy(ico) = huge_offset @@ -746,7 +774,7 @@ subroutine get_yscal(y,dy,htry,yscal,cpatch) yscal%wood_temp(ico) = abs( y%wood_temp(ico)) yscal%wood_water(ico) = max( abs(y%wood_water(ico)) & + abs(dy%wood_water(ico) * htry) & - , rk4leaf_drywhc * y%wai(ico)) + , rk4leaf_drywhc * y%wai(ico)) else yscal%wood_water(ico) = huge_offset yscal%wood_energy(ico) = huge_offset @@ -766,16 +794,6 @@ subroutine get_yscal(y,dy,htry,yscal,cpatch) - !---------------------------------------------------------------------------------------! - ! Scale for wood water and energy. In case the user doesn't want to solve branch ! - ! thermodynamics, the wood area index is too small, or the plant is buried in snow, we ! - ! assign huge values for typical scale, thus preventing unecessary small steps. ! - ! Also, if the cohort has almost no water, make the scale less strict. ! - !---------------------------------------------------------------------------------------! - do ico = 1,cpatch%ncohorts - end do - !---------------------------------------------------------------------------------------! - !---------------------------------------------------------------------------------------! ! Here we just need to make sure the user is checking mass, otherwise these vari- ! ! ables will not be computed at all. If this turns out to be essential, we will make ! @@ -798,6 +816,15 @@ subroutine get_yscal(y,dy,htry,yscal,cpatch) yscal%co2budget_loss2atm = max(yscal%co2budget_loss2atm,1.d-1) end if + if (abs(y%ebudget_netrad) < tiny_offset .and. & + abs(dy%ebudget_netrad) < tiny_offset) then + yscal%ebudget_netrad = 1.d0 + else + yscal%ebudget_netrad = abs(y%ebudget_netrad) & + + abs(dy%ebudget_netrad*htry) + yscal%ebudget_netrad = max(yscal%ebudget_netrad,1.d0) + end if + if (abs(y%ebudget_loss2atm) < tiny_offset .and. & abs(dy%ebudget_loss2atm) < tiny_offset) then yscal%ebudget_loss2atm = 1.d0 @@ -862,6 +889,7 @@ subroutine get_yscal(y,dy,htry,yscal,cpatch) else yscal%co2budget_storage = huge_offset yscal%co2budget_loss2atm = huge_offset + yscal%ebudget_netrad = huge_offset yscal%ebudget_loss2atm = huge_offset yscal%wbudget_loss2atm = huge_offset yscal%ebudget_storage = huge_offset @@ -935,7 +963,7 @@ subroutine get_errmax(errmax,yerr,yscal,cpatch,y,ytemp) ! temperature, water vapour mixing ratio and carbon dioxide mixing ratio are accounted. ! ! Temperature and density will be also checked for sanity. ! !---------------------------------------------------------------------------------------! - err = abs(yerr%can_lntheta/yscal%can_lntheta) + err = abs(yerr%can_enthalpy/yscal%can_enthalpy) errmax = max(errmax,err) if(record_err .and. err > rk4eps) integ_err(1,1) = integ_err(1,1) + 1_8 @@ -1061,29 +1089,33 @@ subroutine get_errmax(errmax,yerr,yscal,cpatch,y,ytemp) errmax = max(errmax,err) if(record_err .and. err > rk4eps) integ_err(14,1) = integ_err(14,1) + 1_8 - err = abs(yerr%ebudget_loss2atm/yscal%ebudget_loss2atm) + err = abs(yerr%ebudget_netrad/yscal%ebudget_netrad) errmax = max(errmax,err) if(record_err .and. err > rk4eps) integ_err(15,1) = integ_err(15,1) + 1_8 + err = abs(yerr%ebudget_loss2atm/yscal%ebudget_loss2atm) + errmax = max(errmax,err) + if(record_err .and. err > rk4eps) integ_err(16,1) = integ_err(17,1) + 1_8 + err = abs(yerr%wbudget_loss2atm/yscal%wbudget_loss2atm) errmax = max(errmax,err) - if(record_err .and. err > rk4eps) integ_err(16,1) = integ_err(16,1) + 1_8 + if(record_err .and. err > rk4eps) integ_err(17,1) = integ_err(18,1) + 1_8 err = abs(yerr%ebudget_loss2drainage/yscal%ebudget_loss2drainage) errmax = max(errmax,err) - if(record_err .and. err > rk4eps) integ_err(17,1) = integ_err(17,1) + 1_8 + if(record_err .and. err > rk4eps) integ_err(18,1) = integ_err(19,1) + 1_8 err = abs(yerr%wbudget_loss2drainage/yscal%wbudget_loss2drainage) errmax = max(errmax,err) - if(record_err .and. err > rk4eps) integ_err(18,1) = integ_err(18,1) + 1_8 + if(record_err .and. err > rk4eps) integ_err(19,1) = integ_err(20,1) + 1_8 err = abs(yerr%ebudget_storage/yscal%ebudget_storage) errmax = max(errmax,err) - if(record_err .and. err > rk4eps) integ_err(19,1) = integ_err(19,1) + 1_8 + if(record_err .and. err > rk4eps) integ_err(20,1) = integ_err(21,1) + 1_8 err = abs(yerr%wbudget_storage/yscal%wbudget_storage) errmax = max(errmax,err) - if(record_err .and. err > rk4eps) integ_err(20,1) = integ_err(20,1) + 1_8 + if(record_err .and. err > rk4eps) integ_err(21,1) = integ_err(22,1) + 1_8 end if !---------------------------------------------------------------------------------------! @@ -1159,8 +1191,7 @@ subroutine copy_rk4_patch(sourcep, targetp, cpatch) integer :: k !---------------------------------------------------------------------------------------! - targetp%can_theiv = sourcep%can_theiv - targetp%can_lntheta = sourcep%can_lntheta + targetp%can_enthalpy = sourcep%can_enthalpy targetp%can_theta = sourcep%can_theta targetp%can_temp = sourcep%can_temp targetp%can_shv = sourcep%can_shv @@ -1168,8 +1199,8 @@ subroutine copy_rk4_patch(sourcep, targetp, cpatch) targetp%can_rhos = sourcep%can_rhos targetp%can_prss = sourcep%can_prss targetp%can_exner = sourcep%can_exner + targetp%can_cp = sourcep%can_cp targetp%can_depth = sourcep%can_depth - targetp%can_rvap = sourcep%can_rvap targetp%can_rhv = sourcep%can_rhv targetp%can_ssh = sourcep%can_ssh targetp%veg_height = sourcep%veg_height @@ -1276,7 +1307,6 @@ subroutine copy_rk4_patch(sourcep, targetp, cpatch) targetp%nplant (k) = sourcep%nplant (k) targetp%lai (k) = sourcep%lai (k) targetp%wai (k) = sourcep%wai (k) - targetp%wpa (k) = sourcep%wpa (k) targetp%tai (k) = sourcep%tai (k) targetp%crown_area (k) = sourcep%crown_area (k) targetp%elongf (k) = sourcep%elongf (k) @@ -1296,6 +1326,7 @@ subroutine copy_rk4_patch(sourcep, targetp, cpatch) if (checkbudget) then targetp%co2budget_storage = sourcep%co2budget_storage targetp%co2budget_loss2atm = sourcep%co2budget_loss2atm + targetp%ebudget_netrad = sourcep%ebudget_netrad targetp%ebudget_loss2atm = sourcep%ebudget_loss2atm targetp%ebudget_loss2drainage = sourcep%ebudget_loss2drainage targetp%ebudget_loss2runoff = sourcep%ebudget_loss2runoff @@ -1408,9 +1439,12 @@ subroutine initialize_rk4patches(init) , patchtype ! ! structure use rk4_coms , only : integration_buff & ! structure , deallocate_rk4_coh & ! structure + , deallocate_rk4_aux & ! structure , allocate_rk4_patch & ! structure , allocate_rk4_coh & ! structure - , allocate_rk4_aux ! ! structure + , allocate_rk4_aux & ! structure + , allocate_bdf2_patch & + , deallocate_bdf2_patch use ed_misc_coms , only : integration_scheme ! ! intent(in) use grid_coms , only : ngrids ! ! intent(in) implicit none @@ -1432,22 +1466,33 @@ subroutine initialize_rk4patches(init) !------------------------------------------------------------------------------------! ! If this is initialization, make sure soil and sfcwater arrays are allocated. ! !------------------------------------------------------------------------------------! - allocate(integration_buff%initp ) - allocate(integration_buff%yscal ) - allocate(integration_buff%y ) - allocate(integration_buff%dydx ) - allocate(integration_buff%yerr ) - allocate(integration_buff%ytemp ) - call allocate_rk4_patch(integration_buff%initp ) - call allocate_rk4_patch(integration_buff%yscal ) - call allocate_rk4_patch(integration_buff%y ) - call allocate_rk4_patch(integration_buff%dydx ) - call allocate_rk4_patch(integration_buff%yerr ) - call allocate_rk4_patch(integration_buff%ytemp ) + select case (integration_scheme) + case (3) - !------ Allocate and initialise the auxiliary structure. ----------------------------! - call allocate_rk4_aux(nzg,nzs) + allocate(integration_buff%initp) + allocate(integration_buff%ytemp) + + call allocate_rk4_patch(integration_buff%initp ) + call allocate_rk4_patch(integration_buff%ytemp ) + + case default + + allocate(integration_buff%initp ) + allocate(integration_buff%yscal ) + allocate(integration_buff%y ) + allocate(integration_buff%dydx ) + allocate(integration_buff%yerr ) + allocate(integration_buff%ytemp ) + + call allocate_rk4_patch(integration_buff%initp ) + call allocate_rk4_patch(integration_buff%yscal ) + call allocate_rk4_patch(integration_buff%y ) + call allocate_rk4_patch(integration_buff%dydx ) + call allocate_rk4_patch(integration_buff%yerr ) + call allocate_rk4_patch(integration_buff%ytemp ) + + end select !------------------------------------------------------------------------------------! @@ -1481,6 +1526,13 @@ subroutine initialize_rk4patches(init) call allocate_rk4_patch(integration_buff%ak2) call allocate_rk4_patch(integration_buff%ak3) + + case (3) !----- Hybrid (forward Euler/BDF2)------------------------------------------! + + allocate(integration_buff%dinitp) + call allocate_rk4_patch(integration_buff%dinitp) + allocate(integration_buff%yprev) + end select !------------------------------------------------------------------------------------! else @@ -1488,12 +1540,21 @@ subroutine initialize_rk4patches(init) ! If this is not initialization, deallocate cohort memory from integration ! ! patches. ! !------------------------------------------------------------------------------------! - call deallocate_rk4_coh(integration_buff%initp ) - call deallocate_rk4_coh(integration_buff%yscal ) - call deallocate_rk4_coh(integration_buff%y ) - call deallocate_rk4_coh(integration_buff%dydx ) - call deallocate_rk4_coh(integration_buff%yerr ) - call deallocate_rk4_coh(integration_buff%ytemp ) + + if(integration_scheme == 3)then + call deallocate_rk4_coh(integration_buff%initp ) + call deallocate_rk4_coh(integration_buff%ytemp ) + else + call deallocate_rk4_coh(integration_buff%initp ) + call deallocate_rk4_coh(integration_buff%yscal ) + call deallocate_rk4_coh(integration_buff%y ) + call deallocate_rk4_coh(integration_buff%dydx ) + call deallocate_rk4_coh(integration_buff%yerr ) + call deallocate_rk4_coh(integration_buff%ytemp ) + end if + + !------ De-allocate the auxiliary structure. ----------------------------------------! + call deallocate_rk4_aux() !------------------------------------------------------------------------------------! ! The following structures are allocated/deallocated depending on the ! @@ -1512,6 +1573,9 @@ subroutine initialize_rk4patches(init) case (2) !----- Heun's. -------------------------------------------------------------! call deallocate_rk4_coh(integration_buff%ak2) call deallocate_rk4_coh(integration_buff%ak3) + case (3) !----- Hybrid --------------------------------------------------------------! + call deallocate_rk4_coh(integration_buff%dinitp) + call deallocate_bdf2_patch(integration_buff%yprev) end select !------------------------------------------------------------------------------------! end if @@ -1534,12 +1598,19 @@ subroutine initialize_rk4patches(init) ! write (unit=*,fmt='(a,1x,i5)') 'Maxcohort = ',maxcohort !----- Create new memory in each of the integration patches. ---------------------------! - call allocate_rk4_coh(maxcohort,integration_buff%initp ) - call allocate_rk4_coh(maxcohort,integration_buff%yscal ) - call allocate_rk4_coh(maxcohort,integration_buff%y ) - call allocate_rk4_coh(maxcohort,integration_buff%dydx ) - call allocate_rk4_coh(maxcohort,integration_buff%yerr ) - call allocate_rk4_coh(maxcohort,integration_buff%ytemp ) + if(integration_scheme == 3)then + call allocate_rk4_coh(maxcohort,integration_buff%initp ) + call allocate_rk4_coh(maxcohort,integration_buff%ytemp ) + else + call allocate_rk4_coh(maxcohort,integration_buff%initp ) + call allocate_rk4_coh(maxcohort,integration_buff%yscal ) + call allocate_rk4_coh(maxcohort,integration_buff%y ) + call allocate_rk4_coh(maxcohort,integration_buff%dydx ) + call allocate_rk4_coh(maxcohort,integration_buff%yerr ) + call allocate_rk4_coh(maxcohort,integration_buff%ytemp ) + end if + !---------------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------------! ! The following structures are allocated/deallocated depending on the integration ! @@ -1558,7 +1629,16 @@ subroutine initialize_rk4patches(init) case (2) !----- Heun's. ----------------------------------------------------------------! call allocate_rk4_coh(maxcohort,integration_buff%ak2 ) call allocate_rk4_coh(maxcohort,integration_buff%ak3 ) + case (3) !----- Hybrid -----------------------------------------------------------------! + call allocate_rk4_coh(maxcohort,integration_buff%dinitp) + call allocate_bdf2_patch(integration_buff%yprev,maxcohort) end select + !---------------------------------------------------------------------------------------! + + + !------ Allocate and initialise the auxiliary structure. -------------------------------! + call allocate_rk4_aux(nzg,nzs,maxcohort) + !---------------------------------------------------------------------------------------! return end subroutine initialize_rk4patches diff --git a/ED/src/dynamics/rk4_misc.f90 b/ED/src/dynamics/rk4_misc.f90 index cec023440..b99fe3680 100644 --- a/ED/src/dynamics/rk4_misc.f90 +++ b/ED/src/dynamics/rk4_misc.f90 @@ -9,21 +9,16 @@ subroutine copy_patch_init(sourcesite,ipa,targetp) use grid_coms , only : nzg & ! intent(in) , nzs ! ! intent(in) use ed_misc_coms , only : fast_diagnostics ! ! intent(in) - use consts_coms , only : cpi8 & ! intent(in) - , ep8 & ! intent(in) - , cp8 & ! intent(in) + use consts_coms , only : ep8 & ! intent(in) , epim18 & ! intent(in) - , alvl8 & ! intent(in) , rdry8 & ! intent(in) , rdryi8 & ! intent(in) - , p00i8 & ! intent(in) - , rocp8 ! ! intent(in) + , cpdry8 & ! intent(in) + , cph2o8 ! ! intent(in) use rk4_coms , only : rk4patchtype & ! structure , rk4site & ! structure , rk4eps & ! intent(in) , any_resolvable & ! intent(out) - , zoveg & ! intent(out) - , zveg & ! intent(out) , wcapcan & ! intent(out) , wcapcani & ! intent(out) , rk4water_stab_thresh & ! intent(in) @@ -35,12 +30,15 @@ subroutine copy_patch_init(sourcesite,ipa,targetp) , find_derived_thbounds & ! sub-routine , reset_rk4_fluxes ! ! sub-routine use ed_max_dims , only : n_pft ! ! intent(in) - use therm_lib8 , only : qwtk8 & ! subroutine + use therm_lib8 , only : uextcm2tl8 & ! subroutine , thetaeiv8 & ! function , idealdenssh8 & ! function , rehuil8 & ! function - , rslif8 & ! function - , reducedpress8 ! ! function + , qslif8 & ! function + , reducedpress8 & ! function + , press2exner8 & ! function + , extheta2temp8 & ! function + , tq2enthalpy8 ! ! function use soil_coms , only : soil8 ! ! intent(in) use ed_therm_lib , only : ed_grndvap8 ! ! subroutine use canopy_struct_dynamics, only : canopy_turbulence8 ! ! subroutine @@ -69,20 +67,13 @@ subroutine copy_patch_init(sourcesite,ipa,targetp) !---------------------------------------------------------------------------------------! !----- Update thermo variables that are conserved between steps. -----------------------! targetp%can_theta = dble(sourcesite%can_theta(ipa)) - targetp%can_theiv = dble(sourcesite%can_theiv(ipa)) targetp%can_shv = dble(sourcesite%can_shv(ipa)) targetp%can_co2 = dble(sourcesite%can_co2(ipa)) targetp%can_depth = dble(sourcesite%can_depth(ipa)) - targetp%can_rvap = targetp%can_shv / (1.d0 - targetp%can_shv) - - !----- Update the canopy pressure and Exner function. ----------------------------------! - targetp%can_prss = reducedpress8(rk4site%atm_prss,rk4site%atm_theta,rk4site%atm_shv & - ,rk4site%geoht,targetp%can_theta,targetp%can_shv & - ,targetp%can_depth) - targetp%can_exner = cp8 * (targetp%can_prss * p00i8) ** rocp8 !---------------------------------------------------------------------------------------! + !----- Update the vegetation properties used for roughness. ----------------------------! targetp%veg_height = dble(sourcesite%veg_height (ipa)) targetp%veg_displace = dble(sourcesite%veg_displace(ipa)) @@ -92,24 +83,53 @@ subroutine copy_patch_init(sourcesite,ipa,targetp) !---------------------------------------------------------------------------------------! - ! Update the natural logarithm of theta_eiv, temperature, density, relative ! - ! humidity, and the saturation specific humidity. ! + ! Update the canopy pressure and Exner function. ! + !---------------------------------------------------------------------------------------! + targetp%can_prss = reducedpress8(rk4site%atm_prss,rk4site%atm_theta,rk4site%atm_shv & + ,rk4site%geoht,targetp%can_theta,targetp%can_shv & + ,targetp%can_depth) + targetp%can_exner = press2exner8 (targetp%can_prss) + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! Initialise canopy air temperature and enthalpy. Enthalpy is the actual ! + ! prognostic variable within one time step. ! + !---------------------------------------------------------------------------------------! + targetp%can_temp = extheta2temp8(targetp%can_exner,targetp%can_theta) + targetp%can_enthalpy = tq2enthalpy8(targetp%can_temp,targetp%can_shv,.true.) + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! Set up the canopy air space heat capacity at constant pressure. ! + !---------------------------------------------------------------------------------------! + targetp%can_cp = (1.d0 - targetp%can_shv) * cpdry8 + targetp%can_shv * cph2o8 + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! Update density, relative humidity, and the saturation specific humidity. ! !---------------------------------------------------------------------------------------! - targetp%can_lntheta = log(targetp%can_theta) - targetp%can_temp = cpi8 * targetp%can_theta * targetp%can_exner targetp%can_rhos = idealdenssh8(targetp%can_prss,targetp%can_temp,targetp%can_shv) - targetp%can_rhv = rehuil8(targetp%can_prss,targetp%can_temp,targetp%can_rvap) - rsat = rslif8(targetp%can_prss,targetp%can_temp) - targetp%can_ssh = rsat / (1.d0 + rsat) + targetp%can_rhv = rehuil8(targetp%can_prss,targetp%can_temp,targetp%can_shv,.true.) + targetp%can_ssh = qslif8(targetp%can_prss,targetp%can_temp) !---------------------------------------------------------------------------------------! + + !----- Find the lower and upper bounds for the derived properties. ---------------------! call find_derived_thbounds(targetp%can_rhos,targetp%can_theta,targetp%can_temp & - ,targetp%can_shv,targetp%can_rvap,targetp%can_prss & - ,targetp%can_depth) + ,targetp%can_shv ,targetp%can_prss ,targetp%can_depth) + !---------------------------------------------------------------------------------------! + + !----- Impose a non-sense number for flag_wflxgc. --------------------------------------! targetp%flag_wflxgc = -1 + !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! ! Soil properties. ! @@ -247,7 +267,6 @@ subroutine copy_patch_init(sourcesite,ipa,targetp) !----- Copy the leaf area index and total (leaf+branch+twig) area index. ------------! targetp%lai(ico) = dble(cpatch%lai(ico)) targetp%wai(ico) = dble(cpatch%wai(ico)) - targetp%wpa(ico) = dble(cpatch%wpa(ico)) targetp%tai(ico) = targetp%lai(ico) + targetp%wai(ico) targetp%crown_area(ico) = dble(cpatch%crown_area(ico)) targetp%elongf(ico) = dble(cpatch%elongf(ico)) * rk4site%green_leaf_factor(ipft) @@ -265,8 +284,9 @@ subroutine copy_patch_init(sourcesite,ipa,targetp) targetp%leaf_water (ico) = max(0.d0,dble(cpatch%leaf_water (ico))) targetp%leaf_hcap (ico) = dble(cpatch%leaf_hcap (ico)) - call qwtk8(targetp%leaf_energy(ico),targetp%leaf_water(ico) & - ,targetp%leaf_hcap(ico),targetp%leaf_temp(ico),targetp%leaf_fliq(ico)) + call uextcm2tl8(targetp%leaf_energy(ico),targetp%leaf_water(ico) & + ,targetp%leaf_hcap(ico),targetp%leaf_temp(ico) & + ,targetp%leaf_fliq(ico)) else targetp%leaf_fliq (ico) = dble(cpatch%leaf_fliq (ico)) targetp%leaf_temp (ico) = dble(cpatch%leaf_temp (ico)) @@ -288,8 +308,9 @@ subroutine copy_patch_init(sourcesite,ipa,targetp) targetp%wood_water (ico) = max(0.d0,dble(cpatch%wood_water (ico))) targetp%wood_hcap (ico) = dble(cpatch%wood_hcap (ico)) - call qwtk8(targetp%wood_energy(ico),targetp%wood_water(ico) & - ,targetp%wood_hcap(ico),targetp%wood_temp(ico),targetp%wood_fliq(ico)) + call uextcm2tl8(targetp%wood_energy(ico),targetp%wood_water(ico) & + ,targetp%wood_hcap(ico),targetp%wood_temp(ico) & + ,targetp%wood_fliq(ico)) else targetp%wood_fliq (ico) = dble(cpatch%wood_fliq (ico)) targetp%wood_temp (ico) = dble(cpatch%wood_temp (ico)) @@ -316,8 +337,7 @@ subroutine copy_patch_init(sourcesite,ipa,targetp) !------------------------------------------------------------------------------------! ! Compute the leaf intercellular specific humidity, assumed to be at saturation. ! !------------------------------------------------------------------------------------! - targetp%lint_shv(ico) = rslif8(targetp%can_prss,targetp%leaf_temp(ico)) - targetp%lint_shv(ico) = targetp%lint_shv(ico) / (1.d0 + targetp%lint_shv(ico)) + targetp%lint_shv(ico) = qslif8(targetp%can_prss,targetp%leaf_temp(ico)) !------------------------------------------------------------------------------------! @@ -401,6 +421,7 @@ subroutine copy_patch_init(sourcesite,ipa,targetp) targetp%ebudget_storage = dble(sourcesite%ebudget_initialstorage(ipa)) targetp%wbudget_storage = dble(sourcesite%wbudget_initialstorage(ipa)) targetp%co2budget_loss2atm = 0.d0 + targetp%ebudget_netrad = 0.d0 targetp%ebudget_loss2atm = 0.d0 targetp%ebudget_loss2drainage = 0.d0 targetp%ebudget_loss2runoff = 0.d0 @@ -519,12 +540,11 @@ subroutine update_diagnostic_vars(initp, csite,ipa) , rk4min_sfcw_mass & ! intent(in) , rk4min_virt_water & ! intent(in) , rk4min_can_shv & ! intent(in) + , rk4max_can_shv & ! intent(in) + , rk4min_can_enthalpy & ! intent(in) + , rk4max_can_enthalpy & ! intent(in) , rk4min_can_theta & ! intent(in) , rk4max_can_theta & ! intent(in) - , rk4min_can_lntheta & ! intent(in) - , rk4max_can_lntheta & ! intent(in) - , rk4min_can_temp & ! intent(in) - , rk4max_can_shv & ! intent(in) , rk4min_veg_lwater & ! intent(in) , rk4min_veg_temp & ! intent(in) , rk4max_veg_temp & ! intent(in) @@ -536,7 +556,6 @@ subroutine update_diagnostic_vars(initp, csite,ipa) , rk4max_sfcw_temp & ! intent(in) , rk4water_stab_thresh & ! intent(in) , tiny_offset & ! intent(in) - , force_idealgas & ! intent(in) , rk4patchtype ! ! structure use ed_state_vars , only : sitetype & ! structure , patchtype ! ! structure @@ -545,26 +564,25 @@ subroutine update_diagnostic_vars(initp, csite,ipa) , dslzi8 ! ! intent(in) use grid_coms , only : nzg & ! intent(in) , nzs ! ! intent(in) - use therm_lib8 , only : qwtk8 & ! subroutine - , qtk8 & ! subroutine + use therm_lib8 , only : uextcm2tl8 & ! subroutine + , uint2tl8 & ! subroutine + , tl2uint8 & ! function + , cmtl2uext8 & ! function , thetaeiv8 & ! function , rehuil8 & ! function - , rslif8 & ! function - , thrhsh2temp8 ! ! function - use consts_coms , only : alvl8 & ! intent(in) + , qslif8 & ! function + , hq2temp8 & ! function + , extemp2theta8 & ! function + , thil2tqall8 ! ! function + use consts_coms , only : t3ple8 & ! intent(in) + , cpdry8 & ! intent(in) + , cph2o8 & ! intent(in) , wdns8 & ! intent(in) , rdryi8 & ! intent(in) , rdry8 & ! intent(in) , epim18 & ! intent(in) , toodry8 & ! intent(in) - , cp8 & ! intent(in) - , cpi8 & ! intent(in) - , p00i8 & ! intent(in) - , rocp8 & ! intent(in) - , t3ple8 & ! intent(in) - , cliq8 & ! intent(in) - , cice8 & ! intent(in) - , tsupercool8 ! ! intent(in) + , t3ple8 ! ! intent(in) use canopy_struct_dynamics, only : canopy_turbulence8 ! ! subroutine use ed_therm_lib , only : ed_grndvap8 ! ! subroutine implicit none @@ -579,6 +597,7 @@ subroutine update_diagnostic_vars(initp, csite,ipa) integer :: ksn integer :: kclosest logical :: ok_shv + logical :: ok_enthalpy logical :: ok_theta logical :: ok_ground logical :: ok_sfcw @@ -600,10 +619,10 @@ subroutine update_diagnostic_vars(initp, csite,ipa) !---------------------------------------------------------------------------------------! !----- Then we define some logicals to make the code cleaner. --------------------------! - ok_shv = initp%can_shv >= rk4min_can_shv .and. & - initp%can_shv <= rk4max_can_shv - ok_theta = initp%can_lntheta >= rk4min_can_lntheta .and. & - initp%can_lntheta <= rk4max_can_lntheta + ok_shv = initp%can_shv >= rk4min_can_shv .and. & + initp%can_shv <= rk4max_can_shv + ok_enthalpy = initp%can_enthalpy >= rk4min_can_enthalpy .and. & + initp%can_enthalpy <= rk4max_can_enthalpy !---------------------------------------------------------------------------------------! ! Here we convert theta into temperature, potential temperature, and density, and ! @@ -611,42 +630,48 @@ subroutine update_diagnostic_vars(initp, csite,ipa) ! log) should eventually become the prognostic variable for canopy air space entropy ! ! when we add condensed/frozen water in the canopy air space. ! !---------------------------------------------------------------------------------------! - if (ok_shv .and. ok_theta) then + if (ok_shv .and. ok_enthalpy) then + + + !----- Update the canopy air space heat capacity at constant pressure. --------------! + initp%can_cp = (1.d0 - initp%can_shv) * cpdry8 + initp%can_shv * cph2o8 + !------------------------------------------------------------------------------------! - !----- First, we update the canopy air potential temperature. -----------------------! - initp%can_theta = exp(initp%can_lntheta) + !----- Find the canopy air temperature. ---------------------------------------------! + initp%can_temp = hq2temp8(initp%can_enthalpy,initp%can_shv,.true.) + !------------------------------------------------------------------------------------! - initp%can_rvap = initp%can_shv / (1.d0 - initp%can_shv) + !----- Find the new potential temperature. ------------------------------------------! + initp%can_theta = extemp2theta8(initp%can_exner,initp%can_temp) !------------------------------------------------------------------------------------! - ! Here we find the temperature in different ways depending on whether we are ! - ! keeping pressure constant during one full time step or not. If we are forcing ! - ! ideal gas to be always respected, then we don't know the pressure until we have ! - ! the temperature, so we compute the temperature based on potential temperature, ! - ! density, and specific humidity, then update pressure. Otherwise, we compute the ! - ! temperature using the known pressure, even though this causes the ideal gas law to ! - ! not be always satisfied. ! + + + !----- Check whether the potential temperature makes sense or not. ------------------! + ok_theta = initp%can_theta >= rk4min_can_theta .and. & + initp%can_theta <= rk4max_can_theta !------------------------------------------------------------------------------------! - if (force_idealgas) then - initp%can_temp = thrhsh2temp8(initp%can_theta,initp%can_rhos,initp%can_shv) - initp%can_prss = initp%can_rhos * rdry8 * initp%can_temp & - * (1.d0 + epim18 * initp%can_shv) - initp%can_exner = cp8 * (initp%can_prss * p00i8) ** rocp8 - else - initp%can_temp = cpi8 * initp%can_theta * initp%can_exner - end if + + + + !------------------------------------------------------------------------------------! + ! Compute the other canopy air parameters only if the potential temperature ! + ! makes sense. Sometimes enthalpy makes sense even though the temperature is bad, ! + ! because can_shv is way off in the opposite direction of temperature. ! !------------------------------------------------------------------------------------! + if (ok_theta) then - initp%can_rhv = rehuil8(initp%can_prss,initp%can_temp,initp%can_rvap) - initp%can_ssh = rslif8(initp%can_prss,initp%can_temp) - initp%can_ssh = initp%can_ssh / (initp%can_ssh + 1.d0) - initp%can_theiv = thetaeiv8(initp%can_theta,initp%can_prss,initp%can_temp & - ,initp%can_rvap,initp%can_rvap) - elseif (initp%can_lntheta >= rk4max_can_lntheta) then - initp%can_theta = rk4max_can_theta + 1.d0 - elseif (initp%can_lntheta <= rk4min_can_lntheta) then - initp%can_theta = rk4min_can_theta - 1.d0 + !---------------------------------------------------------------------------------! + ! Find the derived humidity variables. ! + !---------------------------------------------------------------------------------! + initp%can_rhv = rehuil8(initp%can_prss,initp%can_temp,initp%can_shv,.true.) + initp%can_ssh = qslif8(initp%can_prss,initp%can_temp) + !---------------------------------------------------------------------------------! + end if + else + !----- Either enthalpy or specific humidity is screwed, reject theta too. -----------! + ok_theta = .false. end if !---------------------------------------------------------------------------------------! @@ -657,8 +682,8 @@ subroutine update_diagnostic_vars(initp, csite,ipa) !----- Update soil temperature and liquid water fraction. ------------------------------! do k = rk4site%lsl, nzg soilhcap = soil8(rk4site%ntext_soil(k))%slcpd - call qwtk8(initp%soil_energy(k),initp%soil_water(k)*wdns8,soilhcap & - ,initp%soil_tempk(k),initp%soil_fracliq(k)) + call uextcm2tl8(initp%soil_energy(k),initp%soil_water(k)*wdns8,soilhcap & + ,initp%soil_tempk(k),initp%soil_fracliq(k)) end do !---------------------------------------------------------------------------------------! @@ -704,8 +729,8 @@ subroutine update_diagnostic_vars(initp, csite,ipa) ! are assuming thermal equilibrium, the temperature and liquid fraction of the ! ! attempted layer is the same as the average temperature of the augmented pool. ! !---------------------------------------------------------------------------------! - call qwtk8(energy_tot,wmass_tot,hcapdry_tot & - ,initp%sfcwater_tempk(k),initp%sfcwater_fracliq(k)) + call uextcm2tl8(energy_tot,wmass_tot,hcapdry_tot & + ,initp%sfcwater_tempk(k),initp%sfcwater_fracliq(k)) initp%soil_tempk(nzg) = initp%sfcwater_tempk(k) initp%soil_fracliq(nzg) = initp%sfcwater_fracliq(k) !---------------------------------------------------------------------------------! @@ -717,10 +742,8 @@ subroutine update_diagnostic_vars(initp, csite,ipa) ! constant. ! !---------------------------------------------------------------------------------! initp%sfcwater_energy(k) = initp%sfcwater_mass(k) & - * ( initp%sfcwater_fracliq(k) & - * cliq8 * (initp%sfcwater_tempk(k) - tsupercool8) & - + (1.d0 - initp%sfcwater_fracliq(k)) & - * cice8 * initp%sfcwater_tempk(k) ) + * tl2uint8( initp%sfcwater_tempk(k) & + , initp%sfcwater_fracliq(k) ) !---------------------------------------------------------------------------------! @@ -742,7 +765,7 @@ subroutine update_diagnostic_vars(initp, csite,ipa) ! that would be entirely absorbed by the soil layer. ! !---------------------------------------------------------------------------------! int_sfcw_energy = initp%sfcwater_energy(k)/initp%sfcwater_mass(k) - call qtk8(int_sfcw_energy,initp%sfcwater_tempk(k),initp%sfcwater_fracliq(k)) + call uint2tl8(int_sfcw_energy,initp%sfcwater_tempk(k),initp%sfcwater_fracliq(k)) end if initp%total_sfcw_depth = initp%total_sfcw_depth + initp%sfcwater_depth(k) end do sfcwloop @@ -782,7 +805,7 @@ subroutine update_diagnostic_vars(initp, csite,ipa) continue elseif (abs(initp%virtual_water) > rk4tiny_sfcw_mass) then int_virt_energy = initp%virtual_energy / initp%virtual_water - call qtk8(int_virt_energy,initp%virtual_tempk,initp%virtual_fracliq) + call uint2tl8(int_virt_energy,initp%virtual_tempk,initp%virtual_fracliq) elseif (ksn == 0) then initp%virtual_tempk = initp%soil_tempk(nzg) initp%virtual_fracliq = initp%soil_fracliq(nzg) @@ -900,8 +923,8 @@ subroutine update_diagnostic_vars(initp, csite,ipa) !---------------------------------------------------------------------------! else !----- Find the temperature and liquid fraction. ---------------------------! - call qwtk8(initp%veg_energy(ico),initp%veg_water(ico),initp%veg_hcap(ico) & - ,veg_temp,veg_fliq) + call uextcm2tl8(initp%veg_energy(ico),initp%veg_water(ico) & + ,initp%veg_hcap(ico),veg_temp,veg_fliq) !---------------------------------------------------------------------------! @@ -943,18 +966,15 @@ subroutine update_diagnostic_vars(initp, csite,ipa) !----- Find lead and wood internal energy. ------------------------------! - initp%leaf_energy(ico) = initp%leaf_hcap(ico) * initp%leaf_temp(ico) & - + initp%leaf_water(ico) & - * ( ( 1.d0 - initp%leaf_fliq(ico)) * cice8 & - * initp%leaf_temp(ico) & - + initp%leaf_fliq(ico) * cliq8 & - * (initp%leaf_temp(ico) - tsupercool8) ) - initp%wood_energy(ico) = initp%wood_hcap(ico) * initp%wood_temp(ico) & - + initp%wood_water(ico) & - * ( ( 1.d0 - initp%wood_fliq(ico)) * cice8 & - * initp%wood_temp(ico) & - + initp%wood_fliq(ico) * cliq8 & - * (initp%wood_temp(ico) - tsupercool8) ) + initp%leaf_energy(ico) = cmtl2uext8( initp%leaf_hcap (ico) & + , initp%leaf_water(ico) & + , initp%leaf_temp (ico) & + , initp%leaf_fliq (ico) ) + initp%wood_energy(ico) = cmtl2uext8( initp%wood_hcap (ico) & + , initp%wood_water(ico) & + , initp%wood_temp (ico) & + , initp%wood_fliq (ico) ) + !------------------------------------------------------------------------! @@ -962,8 +982,7 @@ subroutine update_diagnostic_vars(initp, csite,ipa) ! Compute the leaf intercellular specific humidity, assumed to be at ! ! saturation. ! !------------------------------------------------------------------------! - initp%lint_shv(ico) = rslif8(initp%can_prss,initp%leaf_temp(ico)) - initp%lint_shv(ico) = initp%lint_shv(ico) / (1.d0 + initp%lint_shv(ico)) + initp%lint_shv(ico) = qslif8(initp%can_prss,initp%leaf_temp(ico)) !------------------------------------------------------------------------! end if end if @@ -979,9 +998,6 @@ subroutine update_diagnostic_vars(initp, csite,ipa) initp%leaf_water(ico) = 0.d0 initp%wood_water(ico) = 0.d0 initp%veg_water(ico) = 0.d0 - initp%leaf_energy(ico) = initp%leaf_hcap(ico) * initp%leaf_temp(ico) - initp%wood_energy(ico) = initp%wood_hcap(ico) * initp%wood_temp(ico) - initp%veg_energy(ico) = initp%leaf_energy(ico) + initp%wood_energy(ico) if (initp%can_temp == t3ple8) then initp%leaf_fliq(ico) = 5.d-1 initp%wood_fliq(ico) = 5.d-1 @@ -992,6 +1008,16 @@ subroutine update_diagnostic_vars(initp, csite,ipa) initp%leaf_fliq(ico) = 0.d0 initp%wood_fliq(ico) = 0.d0 end if + initp%leaf_energy(ico) = cmtl2uext8( initp%leaf_hcap (ico) & + , initp%leaf_water(ico) & + , initp%leaf_temp (ico) & + , initp%leaf_fliq (ico) ) + + initp%wood_energy(ico) = cmtl2uext8( initp%wood_hcap (ico) & + , initp%wood_water(ico) & + , initp%wood_temp (ico) & + , initp%wood_fliq (ico) ) + initp%veg_energy(ico) = initp%leaf_energy(ico) + initp%wood_energy(ico) !------------------------------------------------------------------------------! @@ -1002,8 +1028,7 @@ subroutine update_diagnostic_vars(initp, csite,ipa) ! Compute the leaf intercellular specific humidity, assumed to be at ! ! saturation. ! !------------------------------------------------------------------------------! - initp%lint_shv(ico) = rslif8(initp%can_prss,initp%leaf_temp(ico)) - initp%lint_shv(ico) = initp%lint_shv(ico) / (1.d0 + initp%lint_shv(ico)) + initp%lint_shv(ico) = qslif8(initp%can_prss,initp%leaf_temp(ico)) !------------------------------------------------------------------------------! end if end do vegloop @@ -1028,8 +1053,9 @@ subroutine update_diagnostic_vars(initp, csite,ipa) ok_leaf = .false. cycle leafloop else - call qwtk8(initp%leaf_energy(ico),initp%leaf_water(ico) & - ,initp%leaf_hcap(ico),initp%leaf_temp(ico),initp%leaf_fliq(ico)) + call uextcm2tl8(initp%leaf_energy(ico),initp%leaf_water(ico) & + ,initp%leaf_hcap(ico),initp%leaf_temp(ico) & + ,initp%leaf_fliq(ico)) if (initp%leaf_temp(ico) < rk4min_veg_temp .or. & initp%leaf_temp(ico) > rk4max_veg_temp) then ok_leaf = .false. @@ -1039,8 +1065,7 @@ subroutine update_diagnostic_vars(initp, csite,ipa) ! Compute the leaf intercellular specific humidity, assumed to be at ! ! saturation. ! !------------------------------------------------------------------------! - initp%lint_shv(ico) = rslif8(initp%can_prss,initp%leaf_temp(ico)) - initp%lint_shv(ico) = initp%lint_shv(ico) / (1.d0 + initp%lint_shv(ico)) + initp%lint_shv(ico) = qslif8(initp%can_prss,initp%leaf_temp(ico)) !------------------------------------------------------------------------! end if end if @@ -1052,7 +1077,11 @@ subroutine update_diagnostic_vars(initp, csite,ipa) !------------------------------------------------------------------------------! initp%leaf_temp(ico) = initp%can_temp initp%leaf_water(ico) = 0.d0 - initp%leaf_energy(ico) = initp%leaf_hcap(ico) * initp%leaf_temp(ico) + initp%leaf_energy(ico) = cmtl2uext8( initp%leaf_hcap (ico) & + , initp%leaf_water(ico) & + , initp%leaf_temp (ico) & + , initp%leaf_fliq (ico) ) + if (initp%leaf_temp(ico) == t3ple8) then initp%leaf_fliq(ico) = 5.d-1 elseif (initp%leaf_temp(ico) > t3ple8) then @@ -1070,8 +1099,7 @@ subroutine update_diagnostic_vars(initp, csite,ipa) ! Compute the leaf intercellular specific humidity, assumed to be at ! ! saturation. ! !------------------------------------------------------------------------------! - initp%lint_shv(ico) = rslif8(initp%can_prss,initp%leaf_temp(ico)) - initp%lint_shv(ico) = initp%lint_shv(ico) / (1.d0 + initp%lint_shv(ico)) + initp%lint_shv(ico) = qslif8(initp%can_prss,initp%leaf_temp(ico)) !------------------------------------------------------------------------------! end if end do leafloop @@ -1101,11 +1129,12 @@ subroutine update_diagnostic_vars(initp, csite,ipa) ok_wood = .false. cycle woodloop else - call qwtk8(initp%wood_energy(ico),initp%wood_water(ico) & - ,initp%wood_hcap(ico),initp%wood_temp(ico),initp%wood_fliq(ico)) + call uextcm2tl8(initp%wood_energy(ico),initp%wood_water(ico) & + ,initp%wood_hcap(ico),initp%wood_temp(ico) & + ,initp%wood_fliq(ico)) if (initp%wood_temp(ico) < rk4min_veg_temp .or. & initp%wood_temp(ico) > rk4max_veg_temp) then - ok_leaf = .false. + ok_wood = .false. cycle woodloop end if end if @@ -1118,7 +1147,11 @@ subroutine update_diagnostic_vars(initp, csite,ipa) !------------------------------------------------------------------------------! initp%wood_temp(ico) = initp%can_temp initp%wood_water(ico) = 0.d0 - initp%wood_energy(ico) = initp%wood_hcap(ico) * initp%wood_temp(ico) + initp%wood_energy(ico) = cmtl2uext8( initp%wood_hcap (ico) & + , initp%wood_water(ico) & + , initp%wood_temp (ico) & + , initp%wood_fliq (ico) ) + if (initp%wood_temp(ico) == t3ple8) then initp%wood_fliq(ico) = 5.d-1 elseif (initp%wood_temp(ico) > t3ple8) then @@ -1145,7 +1178,7 @@ subroutine update_diagnostic_vars(initp, csite,ipa) !------------------------------------------------------------------------------------! end select !---------------------------------------------------------------------------------------! - + !----- Compute canopy turbulence properties. -------------------------------------------! @@ -1179,6 +1212,7 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) use rk4_coms , only : rk4patchtype & ! structure , rk4site & ! intent(in) + , checkbudget & ! intent(in) , rk4min_sfcw_mass & ! intent(in) , rk4min_virt_water & ! intent(in) , rk4water_stab_thresh & ! intent(in) @@ -1189,7 +1223,9 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) , ipercol & ! intent(in) , rk4eps2 & ! intent(in) , wcapcan & ! intent(in) - , wcapcani ! ! intent(in) + , hcapcan & ! intent(in) + , wcapcani & ! intent(in) + , hcapcani ! ! intent(in) use ed_state_vars , only : sitetype & ! structure , patchtype ! ! structure use soil_coms , only : soil8 & ! intent(in) @@ -1197,19 +1233,18 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) , dslzi8 & ! intent(in) , thick & ! intent(in) , thicknet ! ! intent(in) - use consts_coms , only : cice8 & ! intent(in) - , cliq8 & ! intent(in) - , t3ple8 & ! intent(in) + use consts_coms , only : t3ple8 & ! intent(in) , wdns8 & ! intent(in) , wdnsi8 & ! intent(in) - , tsupercool8 & ! intent(in) - , qliqt38 & ! intent(in) + , uiliqt38 & ! intent(in) , wdnsi8 & ! intent(in) - , fdnsi8 & ! intent(in) - , alli8 & ! intent(in) - , alvi8 ! ! intent(in) - use therm_lib8 , only : qtk8 & ! subroutine - , qwtk8 ! ! subroutine + , fdnsi8 ! ! intent(in) + use therm_lib8 , only : uint2tl8 & ! subroutine + , uextcm2tl8 & ! subroutine + , tl2uint8 & ! function + , tq2enthalpy8 & ! function + , alvi8 & ! function + , alvl8 ! ! function implicit none !----- Arguments -----------------------------------------------------------------------! type(rk4patchtype) , target :: initp @@ -1239,12 +1274,19 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) real(kind=8) :: energy_free real(kind=8) :: wmass_free real(kind=8) :: depth_free + real(kind=8) :: tempk_free + real(kind=8) :: fracliq_free + real(kind=8) :: energy_latent real(kind=8) :: energy_available real(kind=8) :: wmass_available real(kind=8) :: depth_available + real(kind=8) :: tempk_available + real(kind=8) :: fracliq_available real(kind=8) :: energy_needed real(kind=8) :: wmass_needed real(kind=8) :: depth_needed + real(kind=8) :: tempk_needed + real(kind=8) :: fracliq_needed real(kind=8) :: wmass_perc real(kind=8) :: energy_perc real(kind=8) :: depth_perc @@ -1269,7 +1311,8 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) !----- Variables used for the water and energy budget. ---------------------------------! real(kind=8) :: wmass_cas_beg real(kind=8) :: wmass_cas_end - real(kind=8) :: energy_input + real(kind=8) :: enthalpy_cas_beg + real(kind=8) :: enthalpy_cas_end real(kind=8) :: wmass_virtual_beg real(kind=8) :: energy_virtual_beg real(kind=8) :: wmass_sfcw_beg @@ -1333,7 +1376,7 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) ! Initialise the budget variables. ! !---------------------------------------------------------------------------------------! wmass_cas_beg = initp%can_shv * wcapcan - energy_input = 0.d0 + enthalpy_cas_beg = initp%can_enthalpy * hcapcan wmass_virtual_beg = initp%virtual_water energy_virtual_beg = initp%virtual_energy wmass_sfcw_beg = sum_sfcw_mass @@ -1342,7 +1385,8 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) energy_soil_beg = initp%soil_energy(nzg) * dslz8(nzg) wmass_total_beg = wmass_virtual_beg + wmass_sfcw_beg + wmass_soil_beg & + wmass_cas_beg - energy_total_beg = energy_virtual_beg + energy_sfcw_beg + energy_soil_beg + energy_total_beg = energy_virtual_beg + energy_sfcw_beg + energy_soil_beg & + + enthalpy_cas_beg !---------------------------------------------------------------------------------------! @@ -1369,41 +1413,75 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) ! the remainder to be stolen from the top soil, but this is dangerous because the ! ! soil may be too dry too. ! !------------------------------------------------------------------------------------! - wmass_needed = - (initp%virtual_water + sum_sfcw_mass ) - energy_needed = - (initp%virtual_energy + sum_sfcw_energy) - depth_needed = - (initp%virtual_depth + sum_sfcw_depth ) + wmass_needed = - (initp%virtual_water + sum_sfcw_mass ) + energy_needed = - (initp%virtual_energy + sum_sfcw_energy) + depth_needed = - (initp%virtual_depth + sum_sfcw_depth ) + !------------------------------------------------------------------------------------! + + !----- Find the amount available at the canopy air space. ---------------------------! - wmass_available = wcapcan * (initp%can_shv - 5.d0 * rk4min_can_shv) - if ( wmass_available > wmass_needed) then + wmass_available = wcapcan * (initp%can_shv - 5.d0 * rk4min_can_shv) + !------------------------------------------------------------------------------------! + + if ( wmass_available >= wmass_needed) then + + !---------------------------------------------------------------------------------! + ! Find the latent heat associated with the phase change. ! + !---------------------------------------------------------------------------------! + call uint2tl8(energy_needed/wmass_needed,tempk_needed,fracliq_needed) + !----- Remove the energy. --------------------------------------------------------! + energy_latent = wmass_needed * ( (1.d0 - fracliq_needed) * alvi8(tempk_needed) & + + fracliq_needed * alvl8(tempk_needed) ) + !---------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------! ! There is enough water vapour. The transfer will require phase change, so the ! ! energy transfer will be a latent heat flux. Remove the water from the canopy ! - ! air space. ! + ! air space. The energy lost by the canopy air space to pad the missing water at ! + ! the virtual+temporary surface water layer must go somewhere, so we add it to ! + ! the soil because it is the closest to the pounding layer. ! + !---------------------------------------------------------------------------------! + initp%can_shv = initp%can_shv - wmass_needed * wcapcani + initp%can_enthalpy = initp%can_enthalpy & + - (energy_needed + energy_latent) * hcapcani + initp%avg_vapor_gc = initp%avg_vapor_gc - wmass_needed * hdidi + initp%soil_energy(nzg) = initp%soil_energy(nzg) + energy_latent * dslzi8(nzg) !---------------------------------------------------------------------------------! - initp%can_shv = initp%can_shv - wmass_needed * wcapcani - initp%avg_vapor_gc = initp%avg_vapor_gc - wmass_needed * hdidi - energy_input = energy_needed wmass_free = 0.d0 energy_free = 0.d0 depth_free = 0.d0 elseif (wmass_available > 0.d0) then + !---------------------------------------------------------------------------------! - ! There is not enough water vapour. Dry down to the minimum, and hope for the ! - ! best. ! + ! Find the latent heat associated with the phase change. ! + !---------------------------------------------------------------------------------! + call uint2tl8(energy_needed/wmass_needed,tempk_needed,fracliq_needed) + !----- Remove the energy. --------------------------------------------------------! + energy_available = wmass_available * energy_needed / wmass_needed + energy_latent = wmass_available * ( (1.d0 - fracliq_needed) & + * alvi8(tempk_needed) & + + fracliq_needed * alvl8(tempk_needed) ) !---------------------------------------------------------------------------------! - energy_available = wmass_available * (alvi8 - initp%soil_fracliq(nzg) * alli8) - depth_available = wmass_available * ( initp%soil_fracliq(nzg) * wdnsi8 & - + (1.d0-initp%soil_fracliq(nzg)) * fdnsi8) - energy_input = energy_available - initp%can_shv = initp%can_shv - wmass_available * wcapcani - initp%avg_vapor_gc = initp%avg_vapor_gc - wmass_available * hdidi - + !---------------------------------------------------------------------------------! + ! There is not enough water vapour. Dry down to the minimum, and correct ! + ! energy. Since there is so little negative mass needed, we include the latent ! + ! heat associated with this condensation to the soil, because otherwise we could ! + ! end up with energy and water mass with opposite signs. ! + !---------------------------------------------------------------------------------! + initp%can_shv = initp%can_shv - wmass_available * wcapcani + initp%can_enthalpy = initp%can_enthalpy & + - ( energy_available + energy_latent ) * hcapcani + initp%avg_vapor_gc = initp%avg_vapor_gc - wmass_available * hdidi + initp%soil_energy(nzg) = initp%soil_energy(nzg) + energy_latent * dslzi8(nzg) + !---------------------------------------------------------------------------------! + wmass_free = wmass_available - wmass_needed energy_free = energy_available - energy_needed depth_free = depth_available - depth_needed @@ -1414,6 +1492,7 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) wmass_free = wmass_needed energy_free = energy_needed depth_free = depth_needed + !---------------------------------------------------------------------------------! end if !----- Reset both the temporary surface water and the virtual layer. ----------------! @@ -1511,7 +1590,7 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) ! are assuming thermal equilibrium, the temperature and liquid fraction of the ! ! attempted layer is the same as the average temperature of the augmented pool. ! !---------------------------------------------------------------------------------! - call qwtk8(energy_tot,wmass_tot,hcapdry_tot,temp_try,fliq_try) + call uextcm2tl8(energy_tot,wmass_tot,hcapdry_tot,temp_try,fliq_try) !---------------------------------------------------------------------------------! @@ -1520,8 +1599,7 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) ! and fraction of liquid water distribution we have just found, keeping the mass ! ! constant. ! !---------------------------------------------------------------------------------! - energy_try = wmass_try * ( fliq_try * cliq8 * (temp_try - tsupercool8) & - + (1.d0 - fliq_try) * cice8 * temp_try ) + energy_try = wmass_try * tl2uint8(temp_try,fliq_try) !---------------------------------------------------------------------------------! @@ -1539,7 +1617,7 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) ! the attempted layer. ! !---------------------------------------------------------------------------------! i_energy_try = energy_try / wmass_try - call qtk8(i_energy_try,temp_try,fliq_try) + call uint2tl8(i_energy_try,temp_try,fliq_try) !---------------------------------------------------------------------------------! end if !------------------------------------------------------------------------------------! @@ -1606,7 +1684,7 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) ! Enough mass to keep this layer. ! !---------------------------------------------------------------------------------! !----- Compute the internal energy and depth associated with percolated water. ---! - energy_perc = wmass_perc * cliq8 * (temp_try - tsupercool8) + energy_perc = wmass_perc * tl2uint8(temp_try,1.d0) depth_perc = wmass_perc * wdnsi8 !----- Find the new water mass and energy for this layer. ------------------------! initp%sfcwater_mass (k) = wmass_try - wmass_perc @@ -1672,7 +1750,7 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) * wdns8 * dslz8(nzg) energy_room = energy_free * wmass_room / wmass_free - if (wmass_room > wmass_free) then + if (wmass_room >= wmass_free) then !---------------------------------------------------------------------------------! ! There is enough space in the top soil layer for the remaining water, put ! ! all the free water there. ! @@ -1685,20 +1763,51 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) energy_free = 0.d0 depth_free = 0.d0 else + !---------------------------------------------------------------------------------! + ! There is not enough space in the top soil layer for the remaining water, ! + ! put what we can there, and boil the remaining. ! + !---------------------------------------------------------------------------------! + + !----- Remove the water that can go to the soil. ---------------------------------! wmass_free = wmass_free - wmass_room energy_free = energy_free - energy_room + !---------------------------------------------------------------------------------! - !----- Dump what we can dump on the top soil layer. ------------------------------! + + !----- Find the amount of latent heat associated with boiling. -------------------! + call uint2tl8(energy_free/wmass_free,tempk_free,fracliq_free) + energy_latent = wmass_free * ( (1.d0 - fracliq_free) * alvi8(tempk_free) & + + fracliq_free * alvl8(tempk_free) ) + !---------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------! + ! Dump what we can dump on the top soil layer. Since no energy will be left ! + ! in the free layer, we must get the energy for latent heat from somewhere, and ! + ! we take it from the top most soil layer. ! + !---------------------------------------------------------------------------------! initp%soil_water(nzg) = initp%soil_water(nzg) + wmass_room * dslzi8(nzg) & * wdnsi8 - initp%soil_energy(nzg) = initp%soil_energy(nzg) + energy_room * dslzi8(nzg) + initp%soil_energy(nzg) = initp%soil_energy(nzg) & + + ( energy_room - energy_latent ) * dslzi8(nzg) + !---------------------------------------------------------------------------------! - !----- Boil the remaining. -------------------------------------------------------! - initp%can_shv = initp%can_shv + wmass_free * wcapcani - initp%avg_vapor_gc = initp%avg_vapor_gc + wmass_free * hdidi - energy_input = -energy_free + !---------------------------------------------------------------------------------! + ! Boil the remaining. ! + !---------------------------------------------------------------------------------! + !------ Update the canopy air space properties. ----------------------------------! + initp%can_shv = initp%can_shv + wmass_free * wcapcani + initp%can_enthalpy = initp%can_enthalpy & + + ( energy_free + energy_latent ) * hcapcani + !---------------------------------------------------------------------------------! + + + !------ Update the fluxes. -------------------------------------------------------! + initp%avg_vapor_gc = initp%avg_vapor_gc + wmass_free * hdidi + !---------------------------------------------------------------------------------! wmass_free = 0.d0 energy_free = 0.d0 @@ -1714,7 +1823,7 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) * wdns8 * dslz8(nzg) energy_available = energy_free * wmass_available / wmass_free - if (wmass_available > wmass_needed) then + if (wmass_available >= wmass_needed) then !---------------------------------------------------------------------------------! ! There is enough space in the top soil layer to correct remaining negative ! ! water, get all the water needed there. ! @@ -1726,20 +1835,44 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) energy_needed = 0.d0 depth_needed = 0.d0 else + !---------------------------------------------------------------------------------! + ! There is not enough space in the top soil layer to correct remaining ! + ! negative water, get all the water we can from the top soil and condense the ! + ! remaining. ! + !---------------------------------------------------------------------------------! + + !----- Add the water that can come from the soil. --------------------------------! wmass_needed = wmass_needed - wmass_available energy_needed = energy_needed - energy_available + !---------------------------------------------------------------------------------! + + + !----- Find the amount of latent heat associated with condensation. --------------! + call uint2tl8(energy_needed/wmass_needed,tempk_needed,fracliq_needed) + energy_latent = wmass_needed * ( (1.d0 - fracliq_needed) * alvi8(tempk_needed) & + + fracliq_needed * alvl8(tempk_needed) ) + !---------------------------------------------------------------------------------! + !----- Dump what we can dump on the top soil layer. ------------------------------! initp%soil_water(nzg) = initp%soil_water(nzg) - wmass_available * dslzi8(nzg) & * wdnsi8 - initp%soil_energy(nzg) = initp%soil_energy(nzg) - energy_available * dslzi8(nzg) + initp%soil_energy(nzg) = initp%soil_energy(nzg) & + - ( energy_available - energy_latent) * dslzi8(nzg) + !---------------------------------------------------------------------------------! - !----- Condense the remaining, hoping for the best. ------------------------------! - initp%can_shv = initp%can_shv - wmass_needed * wcapcani - initp%avg_vapor_gc = initp%avg_vapor_gc - wmass_needed * hdidi - energy_input = - energy_needed + !---------------------------------------------------------------------------------! + ! Condense the remaining, and hope for the best. ! + !---------------------------------------------------------------------------------! + !----- Update the canopy air space properties. -----------------------------------! + initp%can_shv = initp%can_shv - wmass_needed * wcapcani + initp%can_enthalpy = initp%can_enthalpy & + - ( energy_needed + energy_latent ) * hcapcani + !----- Update the fluxes. --------------------------------------------------------! + initp%avg_vapor_gc = initp%avg_vapor_gc - wmass_needed * hdidi + !---------------------------------------------------------------------------------! wmass_free = 0.d0 energy_free = 0.d0 @@ -1826,7 +1959,7 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) !---------------------------------------------------------------------------------! if ( initp%sfcwater_mass(k) > rk4tiny_sfcw_mass .and. & rk4snowmin * thicknet(k) <= sum_sfcw_mass .and. & - initp%sfcwater_energy(k) < initp%sfcwater_mass(k)*qliqt38 ) then + initp%sfcwater_energy(k) < initp%sfcwater_mass(k)*uiliqt38 ) then newlayers = newlayers + 1 end if !---------------------------------------------------------------------------------! @@ -1897,7 +2030,8 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) !---------------------------------------------------------------------------------------! ! Compute the budget variables after the adjustments. ! !---------------------------------------------------------------------------------------! - wmass_cas_end = initp%can_shv * wcapcan + wmass_cas_end = initp%can_shv * wcapcan + enthalpy_cas_end = initp%can_enthalpy * hcapcan wmass_virtual_end = initp%virtual_water energy_virtual_end = initp%virtual_energy wmass_sfcw_end = sum_sfcw_mass @@ -1906,7 +2040,8 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) energy_soil_end = initp%soil_energy(nzg) * dslz8(nzg) wmass_total_end = wmass_virtual_end + wmass_sfcw_end + wmass_soil_end & + wmass_cas_end - energy_total_end = energy_virtual_end + energy_sfcw_end + energy_soil_end + energy_total_end = energy_virtual_end + energy_sfcw_end + energy_soil_end & + + enthalpy_cas_end !---------------------------------------------------------------------------------------! @@ -1914,10 +2049,10 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) !---------------------------------------------------------------------------------------! ! Check whether energy and mass are conserved. ! !---------------------------------------------------------------------------------------! - wmass_total_rch = 2.d0 * abs(wmass_total_end - wmass_total_beg) & - / (abs(wmass_total_end) + abs(wmass_total_beg)) - energy_total_rch = 2.d0 * abs(energy_total_end - energy_input - energy_total_beg) & - / (abs(energy_total_end - energy_input) + abs(energy_total_beg)) + wmass_total_rch = 2.d0 * abs(wmass_total_end - wmass_total_beg) & + / (abs(wmass_total_end ) + abs(wmass_total_beg )) + energy_total_rch = 2.d0 * abs(energy_total_end - energy_total_beg) & + / (abs(energy_total_end) + abs(energy_total_beg)) if (wmass_total_rch > 1.d-6 .or. energy_total_rch > 1.d-6) then write (unit=*,fmt='(a)') '------------------------------------------------' write (unit=*,fmt='(a)') ' Water or energy conservation was violated!!! ' @@ -1930,6 +2065,7 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) write (unit=*,fmt='(a,1x,es14.7)') ' + Ponding/snow mass = ',wmass_sfcw_beg write (unit=*,fmt='(a,1x,es14.7)') ' + Soil mass = ',wmass_soil_beg write (unit=*,fmt='(a,1x,es14.7)') ' + Total energy = ',energy_total_beg + write (unit=*,fmt='(a,1x,es14.7)') ' + CAS enthalpy = ',enthalpy_cas_beg write (unit=*,fmt='(a,1x,es14.7)') ' + Virtual energy = ',energy_virtual_beg write (unit=*,fmt='(a,1x,es14.7)') ' + Ponding/snow energy = ',energy_sfcw_beg write (unit=*,fmt='(a,1x,es14.7)') ' + Soil energy = ',energy_soil_beg @@ -1941,10 +2077,10 @@ subroutine adjust_sfcw_properties(nzg,nzs,initp,hdid,csite,ipa) write (unit=*,fmt='(a,1x,es14.7)') ' + Ponding/snow mass = ',wmass_sfcw_end write (unit=*,fmt='(a,1x,es14.7)') ' + Soil mass = ',wmass_soil_end write (unit=*,fmt='(a,1x,es14.7)') ' + Total energy = ',energy_total_end + write (unit=*,fmt='(a,1x,es14.7)') ' + CAS enthalpy = ',enthalpy_cas_end write (unit=*,fmt='(a,1x,es14.7)') ' + Virtual energy = ',energy_virtual_end write (unit=*,fmt='(a,1x,es14.7)') ' + Ponding/snow energy = ',energy_sfcw_end write (unit=*,fmt='(a,1x,es14.7)') ' + Soil energy = ',energy_soil_end - write (unit=*,fmt='(a,1x,es14.7)') ' + Input energy (cond) = ',energy_input write (unit=*,fmt='(a)') ' ' write (unit=*,fmt='(a)') ' - Relative error: ' write (unit=*,fmt='(a,1x,es14.7)') ' + Total water mass = ',wmass_total_rch @@ -1983,6 +2119,7 @@ end subroutine adjust_sfcw_properties subroutine adjust_topsoil_properties(initp,hdid,csite,ipa) use rk4_coms , only : rk4patchtype & ! structure , rk4site & ! intent(in) + , checkbudget & ! intent(in) , rk4eps & ! intent(in) , rk4tiny_sfcw_mass & ! intent(in) , rk4min_sfcw_mass & ! intent(in) @@ -1994,20 +2131,17 @@ subroutine adjust_topsoil_properties(initp,hdid,csite,ipa) , hcapcani ! ! intent(in) use ed_state_vars , only : sitetype & ! structure , patchtype ! ! structure - use consts_coms , only : cice8 & ! intent(in) - , cliq8 & ! intent(in) - , alvl8 & ! intent(in) - , alvi8 & ! intent(in) - , alli8 & ! intent(in) - , t3ple8 & ! intent(in) + use consts_coms , only : t3ple8 & ! intent(in) , wdns8 & ! intent(in) , fdnsi8 & ! intent(in) , toodry8 & ! intent(in) - , tsupercool8 & ! intent(in) - , qliqt38 & ! intent(in) , wdnsi8 ! ! intent(in) - use therm_lib8 , only : qwtk8 & ! subroutine - , qtk8 ! ! subroutine + use therm_lib8 , only : uextcm2tl8 & ! subroutine + , uint2tl8 & ! subroutine + , tl2uint8 & ! function + , tq2enthalpy8 & ! function + , alvi8 & ! function + , alvl8 ! ! function use grid_coms , only : nzg ! ! intent(in) use soil_coms , only : soil8 & ! intent(in) , dslzi8 & ! intent(in) @@ -2040,6 +2174,9 @@ subroutine adjust_topsoil_properties(initp,hdid,csite,ipa) real(kind=8) :: energy_available real(kind=8) :: water_room real(kind=8) :: energy_room + real(kind=8) :: virtual_tempk + real(kind=8) :: virtual_fracliq + real(kind=8) :: virtual_latent logical :: slightlymoist logical :: slightlydry !---------------------------------------------------------------------------------------! @@ -2061,8 +2198,8 @@ subroutine adjust_topsoil_properties(initp,hdid,csite,ipa) ! now... ! !---------------------------------------------------------------------------------------! shctop = soil8(nstop)%slcpd - call qwtk8(initp%soil_energy(kt),initp%soil_water(kt)*wdns8,shctop & - ,initp%soil_tempk(kt),initp%soil_fracliq(kt)) + call uextcm2tl8(initp%soil_energy(kt),initp%soil_water(kt)*wdns8,shctop & + ,initp%soil_tempk(kt),initp%soil_fracliq(kt)) !---------------------------------------------------------------------------------------! @@ -2187,8 +2324,8 @@ subroutine adjust_topsoil_properties(initp,hdid,csite,ipa) nsbeneath = rk4site%ntext_soil(kb) water_available = (initp%soil_water(kb)-soil8(nsbeneath)%soilcp) * wdns8 * dslz8(kb) shcbeneath = soil8(nsbeneath)%slcpd - call qwtk8(initp%soil_energy(kb),initp%soil_water(kb)*wdns8,shcbeneath & - ,initp%soil_tempk(kb),initp%soil_fracliq(kb)) + call uextcm2tl8(initp%soil_energy(kb),initp%soil_water(kb)*wdns8,shcbeneath & + ,initp%soil_tempk(kb),initp%soil_fracliq(kb)) !------------------------------------------------------------------------------------! @@ -2198,17 +2335,20 @@ subroutine adjust_topsoil_properties(initp,hdid,csite,ipa) ! The layer beneath has enough water. Find the energy associated with this ! ! water. ! !---------------------------------------------------------------------------------! - energy_needed = water_needed * (initp%soil_fracliq(kb) * cliq8 & - * (initp%soil_tempk(kb) - tsupercool8) & - + (1.d0 - initp%soil_fracliq(kb)) * cice8 & - * initp%soil_tempk(kb)) + energy_needed = water_needed & + * tl2uint8(initp%soil_tempk(kb),initp%soil_fracliq(kb)) + !---------------------------------------------------------------------------------! + !----- Update water and energy in both layers. -----------------------------------! initp%soil_water (kt) = initp%soil_water (kt) + water_needed * dslzi8(kt)*wdnsi8 initp%soil_energy(kt) = initp%soil_energy(kt) + energy_needed * dslzi8(kt) initp%soil_water (kb) = initp%soil_water (kb) - water_needed * dslzi8(kb)*wdnsi8 initp%soil_energy(kb) = initp%soil_energy(kb) - energy_needed * dslzi8(kb) - + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! ! We must also update the soil fluxes. ! !---------------------------------------------------------------------------------! @@ -2224,15 +2364,15 @@ subroutine adjust_topsoil_properties(initp,hdid,csite,ipa) ! to reduce the amount we still need. ! !---------------------------------------------------------------------------------! water_needed = water_needed - water_available + !---------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------! ! Find the energy associated with the water that will be transferred. ! !---------------------------------------------------------------------------------! - energy_available = water_available * (initp%soil_fracliq(kb) * cliq8 & - * (initp%soil_tempk(kb) - tsupercool8) & - + (1.d0 - initp%soil_fracliq(kb)) * cice8 & - * initp%soil_tempk(kb)) - + energy_available = water_available & + * tl2uint8(initp%soil_tempk(kb),initp%soil_fracliq(kb)) initp%soil_water(kt) = initp%soil_water(kt) & + water_available * dslzi8(kt) * wdnsi8 initp%soil_energy(kt) = initp%soil_energy(kt) + energy_available * dslzi8(kt) @@ -2240,7 +2380,10 @@ subroutine adjust_topsoil_properties(initp,hdid,csite,ipa) initp%soil_water(kb) = initp%soil_water(kb) & - water_available * dslzi8(kb) * wdnsi8 initp%soil_energy(kb) = initp%soil_energy(kb) - energy_available * dslzi8(kb) - + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! ! We must also update the soil fluxes. ! !---------------------------------------------------------------------------------! @@ -2248,6 +2391,7 @@ subroutine adjust_topsoil_properties(initp,hdid,csite,ipa) initp%avg_smoist_gg(kb) = initp%avg_smoist_gg(kb) - water_available * hdidi !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! @@ -2259,10 +2403,11 @@ subroutine adjust_topsoil_properties(initp,hdid,csite,ipa) if (water_available > water_needed) then !---------------------------------------------------------------------------------! ! There is enough water vapour. The transfer will require phase change, so the ! - ! energy transfer will be a latent heat flux. We use the liquid fraction to ! - ! decide whether it is going to be instant frost or dew (or both). ! + ! energy transfer will contain a latent heat flux of vaporisation. ! + !---------------------------------------------------------------------------------! + energy_needed = water_needed * tq2enthalpy8(initp%soil_tempk(kt),1.d0,.true.) !---------------------------------------------------------------------------------! - energy_needed = water_needed * (alvi8 - initp%soil_fracliq(kt) * alli8) + !---------------------------------------------------------------------------------! ! Add the water and energy into the top layer, remove it from the canopy air ! @@ -2270,10 +2415,17 @@ subroutine adjust_topsoil_properties(initp,hdid,csite,ipa) !---------------------------------------------------------------------------------! initp%soil_water(kt) = initp%soil_water(kt) + water_needed * dslzi8(kt)*wdnsi8 initp%soil_energy(kt) = initp%soil_energy(kt) + energy_needed * dslzi8(kt) + !---------------------------------------------------------------------------------! + - initp%can_shv = initp%can_shv - water_needed * wcapcani + !---------------------------------------------------------------------------------! + ! Remove mass and energy from the canopy air space. ! + !---------------------------------------------------------------------------------! + initp%can_shv = initp%can_shv - water_needed * wcapcani + initp%can_enthalpy = initp%can_enthalpy - energy_needed * hcapcani + initp%avg_vapor_gc = initp%avg_vapor_gc - water_needed * hdidi + !---------------------------------------------------------------------------------! - initp%avg_vapor_gc = initp%avg_vapor_gc - water_needed * hdidi return elseif (water_available > 0.d0) then @@ -2284,7 +2436,15 @@ subroutine adjust_topsoil_properties(initp,hdid,csite,ipa) ! the canopy air space. Even if this is a tiny amount, it may be enough to just ! ! avoid the model to crash at the sanity check. ! !---------------------------------------------------------------------------------! - energy_available = water_available * (alvi8 - initp%soil_fracliq(kt) * alli8) + + + !---------------------------------------------------------------------------------! + ! Find the enthalpy associated with the partial condensation. ! + !---------------------------------------------------------------------------------! + energy_available = water_available & + * tq2enthalpy8(initp%soil_tempk(kt),1.d0,.true.) + !---------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------! ! Add the water and energy into the top layer, remove it from the canopy air ! @@ -2295,7 +2455,9 @@ subroutine adjust_topsoil_properties(initp,hdid,csite,ipa) initp%soil_energy(kt) = initp%soil_energy(kt) + energy_available * dslzi8(kt) initp%can_shv = initp%can_shv - water_available * wcapcani + initp%can_enthalpy = initp%can_enthalpy - energy_available * hcapcani initp%avg_vapor_gc = initp%avg_vapor_gc - water_available * hdidi + !---------------------------------------------------------------------------------! return end if @@ -2310,10 +2472,7 @@ subroutine adjust_topsoil_properties(initp,hdid,csite,ipa) ! units. Also, find the total energy that must go away with the water. ! !------------------------------------------------------------------------------------! water_excess = (initp%soil_water(kt) - soil8(nstop)%slmsts) * dslz8(kt) * wdns8 - energy_excess = water_excess * ( initp%soil_fracliq(kt) * cliq8 & - * (initp%soil_tempk(kt) - tsupercool8) & - + (1.d0 - initp%soil_fracliq(kt)) * cice8 & - * initp%soil_tempk(kt)) + energy_excess = water_excess * tl2uint8(initp%soil_tempk(kt),initp%soil_fracliq(kt)) depth_excess = water_excess * ( initp%soil_fracliq(kt) * wdnsi8 & + (1.d0 - initp%soil_fracliq(kt)) * fdnsi8) !------------------------------------------------------------------------------------! @@ -2330,6 +2489,7 @@ subroutine adjust_topsoil_properties(initp,hdid,csite,ipa) initp%sfcwater_mass(1) = initp%sfcwater_mass(1) + water_excess initp%sfcwater_energy(1) = initp%sfcwater_energy(1) + energy_excess initp%sfcwater_depth(1) = initp%sfcwater_depth(1) + depth_excess + !---------------------------------------------------------------------------------! return elseif (initp%virtual_water + water_excess > rk4tiny_sfcw_mass) then @@ -2345,6 +2505,7 @@ subroutine adjust_topsoil_properties(initp,hdid,csite,ipa) initp%virtual_water = initp%virtual_water + water_excess initp%virtual_energy = initp%virtual_energy + energy_excess initp%virtual_depth = initp%virtual_depth + depth_excess + !---------------------------------------------------------------------------------! return end if @@ -2360,14 +2521,34 @@ subroutine adjust_topsoil_properties(initp,hdid,csite,ipa) ! shouldn't be enough to cause trouble. ! !------------------------------------------------------------------------------------! if (initp%virtual_water > rk4eps * rk4eps * rk4tiny_sfcw_mass) then - initp%can_shv = initp%can_shv + initp%virtual_water * wcapcani - initp%avg_vapor_gc = initp%avg_vapor_gc + initp%virtual_water * hdidi + !---------------------------------------------------------------------------------! + ! Find the associated temperature of the virtual water. The remaining water ! + ! will be boiled. The boiling will eliminate the virtual layer, so the latent ! + ! heat must be taken from somewhere else (top soil layer in this case). ! + !---------------------------------------------------------------------------------! + call uint2tl8(initp%virtual_energy/initp%virtual_water & + ,virtual_tempk,virtual_fracliq) + virtual_latent = initp%virtual_water & + * ( (1.d0 - virtual_fracliq) * alvi8(virtual_tempk) & + + virtual_fracliq * alvl8(virtual_tempk) ) + !---------------------------------------------------------------------------------! + + + !----- Correct the canopy air space and fluxes. ----------------------------------! + initp%can_shv = initp%can_shv + initp%virtual_water * wcapcani + initp%can_enthalpy = initp%can_enthalpy & + + ( initp%virtual_energy + virtual_latent ) * hcapcani + initp%soil_energy(nzg) = initp%soil_energy(nzg) - virtual_latent * dslz8(nzg) + initp%avg_vapor_gc = initp%avg_vapor_gc + initp%virtual_water * hdidi + !---------------------------------------------------------------------------------! + !----- Say goodbye to the virtual layer... ---------------------------------------! initp%virtual_energy = 0.d0 initp%virtual_water = 0.d0 initp%virtual_depth = 0.d0 + !---------------------------------------------------------------------------------! elseif (initp%virtual_water > 0.d0) then !---------------------------------------------------------------------------------! ! The amount of water is so small that round-off errors are bound to become ! @@ -2390,8 +2571,8 @@ subroutine adjust_topsoil_properties(initp,hdid,csite,ipa) kb = nzg-1 nsbeneath = rk4site%ntext_soil(kb) shcbeneath = soil8(nsbeneath)%slcpd - call qwtk8(initp%soil_energy(kb),initp%soil_water(kb)*wdns8,shcbeneath & - ,initp%soil_tempk(kb),initp%soil_fracliq(kb)) + call uextcm2tl8(initp%soil_energy(kb),initp%soil_water(kb)*wdns8,shcbeneath & + ,initp%soil_tempk(kb),initp%soil_fracliq(kb)) water_room = (soil8(nsbeneath)%slmsts-initp%soil_water(kb)) * wdns8 * dslz8(kb) if (water_room > water_excess) then @@ -2416,38 +2597,47 @@ subroutine adjust_topsoil_properties(initp,hdid,csite,ipa) ! will go to the canopy air space. Even if some supersaturation happens, the ! ! excess won't be too much to cause the run to crash. ! !---------------------------------------------------------------------------------! - water_excess = water_excess - water_room - energy_room = water_room * ( initp%soil_fracliq(kt) * cliq8 & - * (initp%soil_tempk(kt) - tsupercool8) & - + (1.d0 - initp%soil_fracliq(kt)) * cice8 & - * initp%soil_tempk(kt)) + water_excess = water_excess - water_room + energy_room = water_room * tl2uint8(initp%soil_tempk(kt),initp%soil_fracliq(kt)) + !---------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------! ! The layer beneath still has some room for this water excess, send the water ! ! down one level. ! !---------------------------------------------------------------------------------! - initp%soil_water(kt) = initp%soil_water(kt) - water_room * dslzi8(kt)*wdnsi8 + initp%soil_water (kt) = initp%soil_water (kt) - water_room * dslzi8(kt) * wdnsi8 initp%soil_energy(kt) = initp%soil_energy(kt) - energy_room * dslzi8(kt) - initp%soil_water(kb) = initp%soil_water(kb) + water_room * dslzi8(kb)*wdnsi8 + initp%soil_water (kb) = initp%soil_water (kb) + water_room * dslzi8(kb) * wdnsi8 initp%soil_energy(kb) = initp%soil_energy(kb) + energy_room * dslzi8(kb) !----- Update the fluxes too... --------------------------------------------------! initp%avg_smoist_gg(kt) = initp%avg_smoist_gg(kt) - water_room * hdidi initp%avg_smoist_gg(kb) = initp%avg_smoist_gg(kb) + water_room * hdidi !---------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------! ! The water that is about to leave will do it through "boiling". Find the ! ! latent heat associated with this phase change. ! !---------------------------------------------------------------------------------! - energy_excess = water_excess * (alvi8 - initp%soil_fracliq(kt) * alli8) + energy_excess = water_excess * tq2enthalpy8(initp%soil_tempk(kt),1.d0,.true.) + !---------------------------------------------------------------------------------! + - !----- Sending the water and energy to the canopy. -------------------------------! + + !----- Send the water and energy to the canopy. ----------------------------------! initp%soil_water(kt) = initp%soil_water(kt) - water_excess * dslzi8(kt)*wdnsi8 initp%soil_energy(kt) = initp%soil_energy(kt) - energy_excess * dslzi8(kt) initp%can_shv = initp%can_shv + water_excess * wcapcani + initp%can_enthalpy = initp%can_enthalpy + energy_excess * hcapcani initp%avg_vapor_gc = initp%avg_vapor_gc + water_excess * hdidi + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! end if + !---------------------------------------------------------------------------------------! return end subroutine adjust_topsoil_properties @@ -2471,6 +2661,7 @@ end subroutine adjust_topsoil_properties subroutine adjust_veg_properties(initp,hdid,csite,ipa) use rk4_coms , only : rk4patchtype & ! structure , rk4site & ! intent(in) + , checkbudget & ! intent(in) , rk4eps & ! intent(in) , rk4min_veg_lwater & ! intent(in) , rk4min_veg_temp & ! intent(in) @@ -2483,17 +2674,12 @@ subroutine adjust_veg_properties(initp,hdid,csite,ipa) use ed_state_vars , only : sitetype & ! structure , patchtype ! ! structure use ed_misc_coms , only : fast_diagnostics ! ! intent(in) - use consts_coms , only : cice8 & ! intent(in) - , cliq8 & ! intent(in) - , alvl8 & ! intent(in) - , alvi8 & ! intent(in) - , alli8 & ! intent(in) - , t3ple8 & ! intent(in) - , tsupercool8 & ! intent(in) - , qliqt38 & ! intent(in) + use consts_coms , only : t3ple8 & ! intent(in) , wdnsi8 & ! intent(in) , fdnsi8 ! ! intent(in) - use therm_lib8 , only : qwtk8 ! ! subroutine + use therm_lib8 , only : uextcm2tl8 & ! subroutine + , tl2uint8 & ! function + , tq2enthalpy8 ! ! function use grid_coms , only : nzg ! ! intent(in) use soil_coms , only : dslzi8 ! ! intent(in) implicit none @@ -2595,8 +2781,8 @@ subroutine adjust_veg_properties(initp,hdid,csite,ipa) ! this happens as loss of internal energy (shedding) or latent heat (fast ! ! dew/boiling). ! !---------------------------------------------------------------------------------! - call qwtk8(initp%leaf_energy(ico),initp%leaf_water(ico),initp%leaf_hcap(ico) & - ,initp%leaf_temp(ico),initp%leaf_fliq(ico)) + call uextcm2tl8(initp%leaf_energy(ico),initp%leaf_water(ico),initp%leaf_hcap(ico) & + ,initp%leaf_temp(ico),initp%leaf_fliq(ico)) old_leaf_energy = initp%leaf_energy(ico) old_leaf_water = initp%leaf_water (ico) old_leaf_temp = initp%leaf_temp (ico) @@ -2609,15 +2795,9 @@ subroutine adjust_veg_properties(initp,hdid,csite,ipa) ! Too much water over these leaves, we shall shed the excess to the ground. ! !------------------------------------------------------------------------------! leaf_wshed = initp%leaf_water(ico) - max_leaf_water - - leaf_qwshed = leaf_wshed & - * ( initp%leaf_fliq(ico) * cliq8 & - * (initp%leaf_temp(ico) - tsupercool8) & - + (1.d0-initp%leaf_fliq(ico)) * cice8 * initp%leaf_temp(ico)) - - leaf_dwshed = leaf_wshed & - * ( initp%leaf_fliq(ico) * wdnsi8 & - + (1.d0-initp%leaf_fliq(ico)) * fdnsi8) + leaf_qwshed = leaf_wshed * tl2uint8(initp%leaf_temp(ico),initp%leaf_fliq(ico)) + leaf_dwshed = leaf_wshed * ( initp%leaf_fliq(ico) * wdnsi8 & + + (1.d0-initp%leaf_fliq(ico)) * fdnsi8) !----- Add the contribution of this cohort to the total shedding. -------------! leaf_wshed_tot = leaf_wshed_tot + leaf_wshed @@ -2634,6 +2814,7 @@ subroutine adjust_veg_properties(initp,hdid,csite,ipa) if (print_detailed) then initp%cfx_qwshed(ico) = initp%cfx_qwshed(ico) + leaf_qwshed * hdidi end if + !------------------------------------------------------------------------------! elseif (initp%leaf_water(ico) < min_leaf_water) then @@ -2645,8 +2826,9 @@ subroutine adjust_veg_properties(initp,hdid,csite,ipa) !------------------------------------------------------------------------------! leaf_boil = max(0.d0, initp%leaf_water(ico)) leaf_dew = max(0.d0,- initp%leaf_water(ico)) - leaf_qboil = leaf_boil * (alvi8 - initp%leaf_fliq(ico) * alli8) - leaf_qdew = leaf_dew * (alvi8 - initp%leaf_fliq(ico) * alli8) + leaf_qboil = leaf_boil * tq2enthalpy8(initp%leaf_temp(ico),1.d0,.true.) + leaf_qdew = leaf_dew * tq2enthalpy8(initp%leaf_temp(ico),1.d0,.true.) + !------------------------------------------------------------------------------! !----- Add the contribution of this cohort to the total boiling. --------------! @@ -2654,18 +2836,23 @@ subroutine adjust_veg_properties(initp,hdid,csite,ipa) leaf_dew_tot = leaf_dew_tot + leaf_dew leaf_qboil_tot = leaf_qboil_tot + leaf_qboil leaf_qdew_tot = leaf_qdew_tot + leaf_qdew + !------------------------------------------------------------------------------! + !----- Update cohort state variables. -----------------------------------------! initp%leaf_water (ico) = 0.d0 initp%veg_water (ico) = initp%veg_water(ico) + leaf_dew - leaf_boil initp%leaf_energy(ico) = initp%leaf_energy(ico) + leaf_qdew - leaf_qboil initp%veg_energy (ico) = initp%veg_energy(ico) + leaf_qdew - leaf_qboil + !------------------------------------------------------------------------------! + !----- Update fluxes if needed be. --------------------------------------------! if (print_detailed) then initp%cfx_qwflxlc(ico) = initp%cfx_qwflxlc(ico) & + (leaf_qboil - leaf_qdew) * hdidi end if + !------------------------------------------------------------------------------! end if end if !------------------------------------------------------------------------------------! @@ -2693,8 +2880,8 @@ subroutine adjust_veg_properties(initp,hdid,csite,ipa) ! this happens as loss of internal energy (shedding) or latent heat (fast ! ! dew/boiling). ! !---------------------------------------------------------------------------------! - call qwtk8(initp%wood_energy(ico),initp%wood_water(ico),initp%wood_hcap(ico) & - ,initp%wood_temp(ico),initp%wood_fliq(ico)) + call uextcm2tl8(initp%wood_energy(ico),initp%wood_water(ico),initp%wood_hcap(ico) & + ,initp%wood_temp(ico),initp%wood_fliq(ico)) old_wood_energy = initp%wood_energy(ico) old_wood_water = initp%wood_water (ico) old_wood_temp = initp%wood_temp (ico) @@ -2707,20 +2894,18 @@ subroutine adjust_veg_properties(initp,hdid,csite,ipa) ! Too much water over the wood, we shall shed the excess to the ground. ! !------------------------------------------------------------------------------! wood_wshed = initp%wood_water(ico) - max_wood_water + wood_qwshed = wood_wshed * tl2uint8(initp%wood_temp(ico),initp%wood_fliq(ico)) + wood_dwshed = wood_wshed * ( initp%wood_fliq(ico) * wdnsi8 & + + (1.d0-initp%wood_fliq(ico)) * fdnsi8) + !------------------------------------------------------------------------------! - wood_qwshed = wood_wshed & - * ( initp%wood_fliq(ico) * cliq8 & - * (initp%wood_temp(ico) - tsupercool8) & - + (1.d0-initp%wood_fliq(ico)) * cice8 * initp%wood_temp(ico)) - - wood_dwshed = wood_wshed & - * ( initp%wood_fliq(ico) * wdnsi8 & - + (1.d0-initp%wood_fliq(ico)) * fdnsi8) !----- Add the contribution of this cohort to the total shedding. -------------! wood_wshed_tot = wood_wshed_tot + wood_wshed wood_qwshed_tot = wood_qwshed_tot + wood_qwshed wood_dwshed_tot = wood_dwshed_tot + wood_dwshed + !------------------------------------------------------------------------------! + !----- Update water mass and energy. ------------------------------------------! initp%wood_water (ico) = initp%wood_water (ico) - wood_wshed @@ -2743,8 +2928,9 @@ subroutine adjust_veg_properties(initp,hdid,csite,ipa) !------------------------------------------------------------------------------! wood_boil = max(0.d0, initp%wood_water(ico)) wood_dew = max(0.d0,- initp%wood_water(ico)) - wood_qboil = wood_boil * (alvi8 - initp%wood_fliq(ico) * alli8) - wood_qdew = wood_dew * (alvi8 - initp%wood_fliq(ico) * alli8) + wood_qboil = wood_boil * tq2enthalpy8(initp%wood_temp(ico),1.d0,.true.) + wood_qdew = wood_dew * tq2enthalpy8(initp%wood_temp(ico),1.d0,.true.) + !------------------------------------------------------------------------------! !----- Add the contribution of this cohort to the total boiling. --------------! @@ -2752,18 +2938,21 @@ subroutine adjust_veg_properties(initp,hdid,csite,ipa) wood_dew_tot = wood_dew_tot + wood_dew wood_qboil_tot = wood_qboil_tot + wood_qboil wood_qdew_tot = wood_qdew_tot + wood_qdew + !------------------------------------------------------------------------------! !----- Update cohort state variables. -----------------------------------------! initp%wood_water (ico) = 0.d0 initp%veg_water (ico) = initp%veg_water (ico) + wood_dew - wood_boil initp%wood_energy(ico) = initp%wood_energy(ico) + wood_qdew - wood_qboil initp%veg_energy (ico) = initp%veg_energy (ico) + wood_qdew - wood_qboil + !------------------------------------------------------------------------------! !----- Update fluxes if needed be. --------------------------------------------! if (print_detailed) then initp%cfx_qwflxwc(ico) = initp%cfx_qwflxwc(ico) & + (wood_qboil - wood_qdew) * hdidi end if + !------------------------------------------------------------------------------! end if end if !------------------------------------------------------------------------------------! @@ -2802,11 +2991,19 @@ subroutine adjust_veg_properties(initp,hdid,csite,ipa) !------------------------------------------------------------------------------------! end select + !---------------------------------------------------------------------------------------! + + + + !----- Update the canopy air specific humidity and enthalpy. ---------------------------! + initp%can_shv = initp%can_shv & + + (leaf_boil_tot + wood_boil_tot - leaf_dew_tot - wood_dew_tot) & + * wcapcani + initp%can_enthalpy = initp%can_enthalpy & + + (leaf_qboil_tot + wood_qboil_tot - leaf_qdew_tot - wood_qdew_tot) & + * hcapcani + !---------------------------------------------------------------------------------------! - !----- Update the canopy air specific humidity. ----------------------------------------! - initp%can_shv = initp%can_shv & - + (leaf_boil_tot + wood_boil_tot - leaf_dew_tot - wood_dew_tot) & - * wcapcani !----- Updating output fluxes ----------------------------------------------------------! @@ -2866,7 +3063,7 @@ subroutine print_errmax(errmax,yerr,yscal,cpatch,y,ytemp) !----- Constants -----------------------------------------------------------------------! character(len=28) , parameter :: onefmt = '(a16,1x,3(es12.4,1x),11x,l1)' character(len=34) , parameter :: lyrfmt = '(a16,1x,i6,1x,3(es12.4,1x),11x,l1)' - character(len=34) , parameter :: cohfmt = '(a16,1x,i6,1x,7(es12.4,1x),11x,l1)' + character(len=34) , parameter :: cohfmt = '(a16,1x,i6,1x,6(es12.4,1x),11x,l1)' !----- Functions -----------------------------------------------------------------------! logical , external :: large_error !---------------------------------------------------------------------------------------! @@ -2881,10 +3078,10 @@ subroutine print_errmax(errmax,yerr,yscal,cpatch,y,ytemp) write(unit=*,fmt='(5(a,1x))') 'Name ',' Max.Error',' Abs.Error'& &,' Scale','Problem(T|F)' - errmax = max(0.0,abs(yerr%can_lntheta/yscal%can_lntheta)) - troublemaker = large_error(yerr%can_theiv,yscal%can_theiv) - write(unit=*,fmt=onefmt) 'CAN_LNTHETA:',errmax,yerr%can_lntheta,yscal%can_lntheta & - ,troublemaker + errmax = max(0.d0,abs(yerr%can_enthalpy/yscal%can_enthalpy)) + troublemaker = large_error(yerr%can_enthalpy,yscal%can_enthalpy) + write(unit=*,fmt=onefmt) 'CAN_ENTHALPY:',errmax,yerr%can_enthalpy,yscal%can_enthalpy & + ,troublemaker errmax = max(errmax,abs(yerr%can_shv/yscal%can_shv)) troublemaker = large_error(yerr%can_shv,yscal%can_shv) @@ -2960,16 +3157,15 @@ subroutine print_errmax(errmax,yerr,yscal,cpatch,y,ytemp) write(unit=*,fmt='(a)' ) write(unit=*,fmt='(80a)') ('-',k=1,80) write(unit=*,fmt='(a)' ) ' Veg-level variables (only the resolvable ones):' - write(unit=*,fmt='(10(a,1x))') 'Name ',' PFT',' LAI' & - ,' WAI',' WPA',' TAI' & - ,' Max.Error',' Abs.Error',' Scale' & - ,'Problem(T|F)' + write(unit=*,fmt='(9(a,1x))') 'Name ',' PFT',' LAI' & + ,' WAI',' TAI',' Max.Error' & + ,' Abs.Error',' Scale','Problem(T|F)' do ico = 1,cpatch%ncohorts if (y%veg_resolvable(ico)) then errmax = max(errmax,abs(yerr%veg_water(ico)/yscal%veg_water(ico))) troublemaker = large_error(yerr%veg_water(ico),yscal%veg_water(ico)) write(unit=*,fmt=cohfmt) 'VEG_WATER:',cpatch%pft(ico),y%lai(ico),y%wai(ico) & - ,y%wpa(ico),y%tai(ico),errmax & + ,y%tai(ico),errmax & ,yerr%veg_water(ico) & ,yscal%veg_water(ico),troublemaker @@ -2977,7 +3173,7 @@ subroutine print_errmax(errmax,yerr,yscal,cpatch,y,ytemp) errmax = max(errmax,abs(yerr%veg_energy(ico)/yscal%veg_energy(ico))) troublemaker = large_error(yerr%veg_energy(ico),yscal%veg_energy(ico)) write(unit=*,fmt=cohfmt) 'VEG_ENERGY:',cpatch%pft(ico),cpatch%lai(ico) & - ,y%wai(ico),y%wpa(ico),y%tai(ico) & + ,y%wai(ico),y%tai(ico) & ,errmax,yerr%veg_energy(ico) & ,yscal%veg_energy(ico) & ,troublemaker @@ -2994,23 +3190,22 @@ subroutine print_errmax(errmax,yerr,yscal,cpatch,y,ytemp) write(unit=*,fmt='(a)' ) write(unit=*,fmt='(80a)') ('-',k=1,80) write(unit=*,fmt='(a)' ) ' Leaf-level variables (only the resolvable ones):' - write(unit=*,fmt='(10(a,1x))') 'Name ',' PFT',' LAI' & - ,' WAI',' WPA',' TAI' & - ,' Max.Error',' Abs.Error',' Scale' & - ,'Problem(T|F)' + write(unit=*,fmt='(9(a,1x))') 'Name ',' PFT',' LAI' & + ,' WAI',' TAI',' Max.Error' & + ,' Abs.Error',' Scale','Problem(T|F)' do ico = 1,cpatch%ncohorts if (y%leaf_resolvable(ico)) then errmax = max(errmax,abs(yerr%leaf_water(ico)/yscal%leaf_water(ico))) troublemaker = large_error(yerr%leaf_water(ico),yscal%leaf_water(ico)) write(unit=*,fmt=cohfmt) 'LEAF_WATER:',cpatch%pft(ico),y%lai(ico),y%wai(ico) & - ,y%wpa(ico),y%tai(ico),errmax & + ,y%tai(ico),errmax & ,yerr%leaf_water(ico) & ,yscal%leaf_water(ico),troublemaker errmax = max(errmax,abs(yerr%leaf_energy(ico)/yscal%leaf_energy(ico))) troublemaker = large_error(yerr%leaf_energy(ico),yscal%leaf_energy(ico)) write(unit=*,fmt=cohfmt) 'LEAF_ENERGY:',cpatch%pft(ico),cpatch%lai(ico) & - ,y%wai(ico),y%wpa(ico),y%tai(ico) & + ,y%wai(ico),y%tai(ico) & ,errmax,yerr%leaf_energy(ico) & ,yscal%leaf_energy(ico) & ,troublemaker @@ -3028,23 +3223,22 @@ subroutine print_errmax(errmax,yerr,yscal,cpatch,y,ytemp) write(unit=*,fmt='(a)' ) write(unit=*,fmt='(80a)') ('-',k=1,80) write(unit=*,fmt='(a)' ) ' Wood-level variables (only the resolvable ones):' - write(unit=*,fmt='(10(a,1x))') 'Name ',' PFT',' LAI' & - ,' WAI',' WPA',' TAI' & - ,' Max.Error',' Abs.Error',' Scale' & - ,'Problem(T|F)' + write(unit=*,fmt='(9(a,1x))') 'Name ',' PFT',' LAI' & + ,' WAI',' TAI',' Max.Error' & + ,' Abs.Error',' Scale','Problem(T|F)' do ico = 1,cpatch%ncohorts if (y%wood_resolvable(ico)) then errmax = max(errmax,abs(yerr%wood_water(ico)/yscal%wood_water(ico))) troublemaker = large_error(yerr%wood_water(ico),yscal%wood_water(ico)) write(unit=*,fmt=cohfmt) 'WOOD_WATER:',cpatch%pft(ico),y%lai(ico),y%wai(ico) & - ,y%wpa(ico),y%tai(ico),errmax & + ,y%tai(ico),errmax & ,yerr%wood_water(ico) & ,yscal%wood_water(ico),troublemaker errmax = max(errmax,abs(yerr%wood_energy(ico)/yscal%wood_energy(ico))) troublemaker = large_error(yerr%wood_energy(ico),yscal%wood_energy(ico)) write(unit=*,fmt=cohfmt) 'WOOD_ENERGY:',cpatch%pft(ico),cpatch%lai(ico) & - ,y%wai(ico),y%wpa(ico),y%tai(ico) & + ,y%wai(ico),y%tai(ico) & ,errmax,yerr%wood_energy(ico) & ,yscal%wood_energy(ico),troublemaker end if @@ -3076,6 +3270,13 @@ subroutine print_errmax(errmax,yerr,yscal,cpatch,y,ytemp) write(unit=*,fmt=onefmt) 'CO2LOSS2ATM:',errmax,yerr%co2budget_loss2atm & ,yscal%co2budget_loss2atm,troublemaker + errmax = max(errmax & + ,abs(yerr%ebudget_netrad/yscal%ebudget_netrad)) + troublemaker = large_error(yerr%ebudget_netrad & + ,yscal%ebudget_netrad) + write(unit=*,fmt=onefmt) 'ENNETRAD:',errmax,yerr%ebudget_netrad & + ,yscal%ebudget_netrad,troublemaker + errmax = max(errmax & ,abs(yerr%ebudget_loss2atm/yscal%ebudget_loss2atm)) troublemaker = large_error(yerr%ebudget_loss2atm & @@ -3338,8 +3539,7 @@ subroutine print_rk4patch(y,csite,ipa) , nzs ! ! intent(in) use ed_misc_coms , only : current_time ! ! intent(in) use consts_coms , only : pio1808 ! ! intent(in) - use therm_lib8 , only : qtk8 & ! subroutine - , qwtk8 ! ! subroutine + use therm_lib8 , only : thetaeiv8 ! ! function implicit none !----- Arguments -----------------------------------------------------------------------! type(rk4patchtype) , target :: y @@ -3349,6 +3549,13 @@ subroutine print_rk4patch(y,csite,ipa) type(patchtype) , pointer :: cpatch integer :: k integer :: ico + real(kind=8) :: y_can_rvap + real(kind=8) :: y_can_theiv + !---------------------------------------------------------------------------------------! + + !----- Find the ice-vapour equivalent potential temperature (output only). -------------! + y_can_rvap = y%can_shv / (1.d0 - y%can_shv) + y_can_theiv = thetaeiv8(y%can_theta,y%can_prss,y%can_temp,y_can_rvap,y_can_rvap) !---------------------------------------------------------------------------------------! cpatch => csite%patch(ipa) @@ -3369,24 +3576,26 @@ subroutine print_rk4patch(y,csite,ipa) write (unit=*,fmt='(80a)') ('-',k=1,80) write (unit=*,fmt='(a)') ' ATMOSPHERIC CONDITIONS: ' - write (unit=*,fmt='(a,1x,es12.4)') ' Longitude : ',rk4site%lon - write (unit=*,fmt='(a,1x,es12.4)') ' Latitude : ',rk4site%lat - write (unit=*,fmt='(a,1x,es12.4)') ' Air temperature : ',rk4site%atm_tmp - write (unit=*,fmt='(a,1x,es12.4)') ' Air potential temp. : ',rk4site%atm_theta - write (unit=*,fmt='(a,1x,es12.4)') ' Air theta_Eiv : ',rk4site%atm_theiv - write (unit=*,fmt='(a,1x,es12.4)') ' H2Ov mixing ratio : ',rk4site%atm_shv - write (unit=*,fmt='(a,1x,es12.4)') ' CO2 mixing ratio : ',rk4site%atm_co2 - write (unit=*,fmt='(a,1x,es12.4)') ' Pressure : ',rk4site%atm_prss - write (unit=*,fmt='(a,1x,es12.4)') ' Exner function : ',rk4site%atm_exner - write (unit=*,fmt='(a,1x,es12.4)') ' Wind speed : ',rk4site%vels - write (unit=*,fmt='(a,1x,es12.4)') ' Height : ',rk4site%geoht - write (unit=*,fmt='(a,1x,es12.4)') ' Precip. mass flux : ',rk4site%pcpg - write (unit=*,fmt='(a,1x,es12.4)') ' Precip. heat flux : ',rk4site%qpcpg - write (unit=*,fmt='(a,1x,es12.4)') ' Precip. depth flux : ',rk4site%dpcpg - write (unit=*,fmt='(a,1x,es12.4)') ' Downward SW radiation : ',rk4site%rshort - write (unit=*,fmt='(a,1x,es12.4)') ' Downward LW radiation : ',rk4site%rlong - write (unit=*,fmt='(a,1x,es12.4)') ' Zenith angle (deg) : ',acos(rk4site%cosz) & - / pio1808 + write (unit=*,fmt='(a,1x,es12.4)') ' Longitude : ',rk4site%lon + write (unit=*,fmt='(a,1x,es12.4)') ' Latitude : ',rk4site%lat + write (unit=*,fmt='(a,1x,es12.4)') ' Air temperature (Ref. hgt.): ',rk4site%atm_tmp + write (unit=*,fmt='(a,1x,es12.4)') ' Air temperature (Can. hgt.): ',rk4site%atm_tmp_zcan + write (unit=*,fmt='(a,1x,es12.4)') ' Air potential temp. : ',rk4site%atm_theta + write (unit=*,fmt='(a,1x,es12.4)') ' Air theta_Eiv : ',rk4site%atm_theiv + write (unit=*,fmt='(a,1x,es12.4)') ' Air sp. enthalpy (can.hgt.): ',rk4site%atm_enthalpy + write (unit=*,fmt='(a,1x,es12.4)') ' H2Ov mixing ratio : ',rk4site%atm_shv + write (unit=*,fmt='(a,1x,es12.4)') ' CO2 mixing ratio : ',rk4site%atm_co2 + write (unit=*,fmt='(a,1x,es12.4)') ' Pressure : ',rk4site%atm_prss + write (unit=*,fmt='(a,1x,es12.4)') ' Exner function : ',rk4site%atm_exner + write (unit=*,fmt='(a,1x,es12.4)') ' Wind speed : ',rk4site%vels + write (unit=*,fmt='(a,1x,es12.4)') ' Height : ',rk4site%geoht + write (unit=*,fmt='(a,1x,es12.4)') ' Precip. mass flux : ',rk4site%pcpg + write (unit=*,fmt='(a,1x,es12.4)') ' Precip. heat flux : ',rk4site%qpcpg + write (unit=*,fmt='(a,1x,es12.4)') ' Precip. depth flux : ',rk4site%dpcpg + write (unit=*,fmt='(a,1x,es12.4)') ' Downward SW radiation : ',rk4site%rshort + write (unit=*,fmt='(a,1x,es12.4)') ' Downward LW radiation : ',rk4site%rlong + write (unit=*,fmt='(a,1x,es12.4)') ' Zenith angle (deg) : ',acos(rk4site%cosz) & + / pio1808 write (unit=*,fmt='(80a)') ('=',k=1,80) write (unit=*,fmt='(a)' ) 'Leaf information (only those resolvable are shown): ' @@ -3522,14 +3731,14 @@ subroutine print_rk4patch(y,csite,ipa) ,csite%lai(ipa),y%can_depth,y%can_co2,y%can_prss & ,y%ggnet write (unit=*,fmt='(80a)') ('-',k=1,80) - write (unit=*,fmt='(8(a12,1x))') ' CAN_RHOS',' CAN_THEIV',' CAN_THETA' & + write (unit=*,fmt='(9(a12,1x))') ' CAN_RHOS',' CAN_THEIV',' CAN_THETA' & ,' CAN_TEMP',' CAN_SHV',' CAN_SSH' & - ,' CAN_RVAP',' CAN_RHV' + ,' CAN_RVAP',' CAN_RHV','CAN_ENTHALPY' - write (unit=*,fmt='(8(es12.4,1x))') y%can_rhos , y%can_theiv, y%can_theta & - , y%can_temp , y%can_shv , y%can_ssh & - , y%can_rvap , y%can_rhv + write (unit=*,fmt='(9(es12.4,1x))') y%can_rhos , y_can_theiv , y%can_theta & + , y%can_temp , y%can_shv , y%can_ssh & + , y_can_rvap , y%can_rhv , y%can_enthalpy write (unit=*,fmt='(80a)') ('-',k=1,80) @@ -3616,7 +3825,8 @@ subroutine print_rk4_state(initp,fluxp,csite,ipa,elapsed,hdid) use rk4_coms , only : rk4patchtype & ! structure , rk4site & ! intent(in) , detail_pref ! ! intent(in) - use therm_lib8 , only : qwtk8 ! ! sub-routine + use therm_lib8 , only : uextcm2tl8 & ! sub-routine + , thetaeiv8 ! ! function use soil_coms , only : soil8 ! ! intent(in) implicit none !----- Arguments. ----------------------------------------------------------------------! @@ -3660,9 +3870,11 @@ subroutine print_rk4_state(initp,fluxp,csite,ipa,elapsed,hdid) real(kind=8) :: nir_b_beam real(kind=8) :: nir_b_diff real(kind=8) :: elapsec + real(kind=8) :: can_rvap + real(kind=8) :: can_theiv !----- Local constants. ----------------------------------------------------------------! - character(len=10), parameter :: phfmt='(82(a,1x))' - character(len=48), parameter :: pbfmt='(3(i13,1x),4(es13.6,1x),3(i13,1x),72(es13.6,1x))' + character(len=10), parameter :: phfmt='(83(a,1x))' + character(len=48), parameter :: pbfmt='(3(i13,1x),4(es13.6,1x),3(i13,1x),73(es13.6,1x))' character(len=10), parameter :: chfmt='(57(a,1x))' character(len=48), parameter :: cbfmt='(3(i13,1x),2(es13.6,1x),3(i13,1x),49(es13.6,1x))' !----- Locally saved variables. --------------------------------------------------------! @@ -3751,6 +3963,15 @@ subroutine print_rk4_state(initp,fluxp,csite,ipa,elapsed,hdid) end do !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! + ! Find the ice-vapour equivalent potential temperature of the canopy air space. ! + !---------------------------------------------------------------------------------------! + can_rvap = initp%can_shv / (1.d0 - initp%can_shv) + can_theiv = thetaeiv8( initp%can_theta , initp%can_prss , initp%can_temp & + , can_rvap , can_rvap ) + !---------------------------------------------------------------------------------------! + par_b_beam = dble(csite%par_b_beam (ipa)) par_b_diff = dble(csite%par_b_diffuse(ipa)) nir_b_beam = dble(csite%nir_b_beam (ipa)) @@ -3771,7 +3992,8 @@ subroutine print_rk4_state(initp,fluxp,csite,ipa,elapsed,hdid) avg_leaf_fliq = 0.d0 end if else - call qwtk8(sum_leaf_energy,sum_leaf_water,sum_leaf_hcap,avg_leaf_temp,avg_leaf_fliq) + call uextcm2tl8(sum_leaf_energy,sum_leaf_water,sum_leaf_hcap & + ,avg_leaf_temp,avg_leaf_fliq) end if !---------------------------------------------------------------------------------------! @@ -3791,7 +4013,8 @@ subroutine print_rk4_state(initp,fluxp,csite,ipa,elapsed,hdid) avg_wood_fliq = 0.d0 end if else - call qwtk8(sum_wood_energy,sum_wood_water,sum_wood_hcap,avg_wood_temp,avg_wood_fliq) + call uextcm2tl8(sum_wood_energy,sum_wood_water,sum_wood_hcap & + ,avg_wood_temp,avg_wood_fliq) end if !---------------------------------------------------------------------------------------! @@ -3830,24 +4053,24 @@ subroutine print_rk4_state(initp,fluxp,csite,ipa,elapsed,hdid) , ' MET.RSHORT' , ' MET.RLONG', ' CAN.PRSS' & , ' CAN.TEMP' , ' CAN.SHV', ' CAN.CO2' & , ' CAN.DEPTH' , ' CAN.RHOS', ' CAN.RELHUM' & - , ' CAN.THETA' , ' CAN.THEIV', ' SFC.TEMP' & - , ' SFC.SHV' , ' LEAF.TEMP', ' LEAF.WATER' & - , ' WOOD.TEMP' , ' WOOD.WATER', ' GGBARE' & - , ' GGVEG' , ' GGNET', ' OPENCAN' & - , ' SOIL.TEMP' , ' SOIL.WATER', ' SOILCP' & - , ' SOILWP' , ' SOILFC', ' SLMSTS' & - , ' USTAR' , ' TSTAR', ' QSTAR' & - , ' CSTAR' , ' ZETA', ' RI.BULK' & - , ' GND.RSHORT' , ' GND.RLONG', ' WFLXLC' & - , ' WFLXWC' , ' WFLXGC', ' WFLXAC' & - , ' TRANSP' , ' WSHED', ' INTERCEPT' & - , ' THROUGHFALL' , ' HFLXGC', ' HFLXLC' & - , ' HFLXWC' , ' HFLXAC', ' CFLXAC' & - , ' CFLXST' , ' CWDRH', ' SOILRH' & - , ' GPP' , ' PLRESP', ' PAR.BEAM.TOP' & - , ' PAR.DIFF.TOP' , ' NIR.BEAM.TOP', ' NIR.DIFF.TOP' & - , ' PAR.BEAM.BOT' , ' PAR.DIFF.BOT', ' NIR.BEAM.BOT' & - , ' NIR.DIFF.BOT' + , ' CAN.THETA' , ' CAN.THEIV', ' CAN.ENTHALPY' & + , ' SFC.TEMP', ' SFC.SHV' , ' LEAF.TEMP' & + , ' LEAF.WATER', ' WOOD.TEMP' , ' WOOD.WATER' & + , ' GGBARE', ' GGVEG' , ' GGNET' & + , ' OPENCAN', ' SOIL.TEMP' , ' SOIL.WATER' & + , ' SOILCP', ' SOILWP' , ' SOILFC' & + , ' SLMSTS', ' USTAR' , ' TSTAR' & + , ' QSTAR', ' CSTAR' , ' ZETA' & + , ' RI.BULK', ' GND.RSHORT' , ' GND.RLONG' & + , ' WFLXLC', ' WFLXWC' , ' WFLXGC' & + , ' WFLXAC', ' TRANSP' , ' WSHED' & + , ' INTERCEPT', ' THROUGHFALL' , ' HFLXGC' & + , ' HFLXLC', ' HFLXWC' , ' HFLXAC' & + , ' CFLXAC', ' CFLXST' , ' CWDRH' & + , ' SOILRH', ' GPP' , ' PLRESP' & + , ' PAR.BEAM.TOP', ' PAR.DIFF.TOP' , ' NIR.BEAM.TOP' & + , ' NIR.DIFF.TOP', ' PAR.BEAM.BOT' , ' PAR.DIFF.BOT' & + , ' NIR.BEAM.BOT', ' NIR.DIFF.BOT' @@ -3874,24 +4097,24 @@ subroutine print_rk4_state(initp,fluxp,csite,ipa,elapsed,hdid) , rk4site%rshort , rk4site%rlong , initp%can_prss & , initp%can_temp , initp%can_shv , initp%can_co2 & , initp%can_depth , initp%can_rhos , initp%can_rhv & - , initp%can_theta , initp%can_theiv , initp%ground_temp & - , initp%ground_shv , avg_leaf_temp , sum_leaf_water & - , avg_wood_temp , sum_wood_water , initp%ggbare & - , initp%ggveg , initp%ggnet , initp%opencan_frac & - , initp%soil_tempk(nzg) , initp%soil_water(nzg) , soil8(nsoil)%soilcp & - , soil8(nsoil)%soilwp , soil8(nsoil)%sfldcap , soil8(nsoil)%slmsts & - , initp%ustar , initp%tstar , initp%qstar & - , initp%cstar , initp%zeta , initp%ribulk & - , fluxp%flx_rshort_gnd , fluxp%flx_rlong_gnd , fluxp%flx_vapor_lc & - , fluxp%flx_vapor_wc , fluxp%flx_vapor_gc , fluxp%flx_vapor_ac & - , fluxp%flx_transp , fluxp%flx_wshed_vg , fluxp%flx_intercepted & - , fluxp%flx_throughfall , fluxp%flx_sensible_gc , fluxp%flx_sensible_lc & - , fluxp%flx_sensible_wc , fluxp%flx_sensible_ac , fluxp%flx_carbon_ac & - , fluxp%flx_carbon_st , initp%cwd_rh , soil_rh & - , sum_gpp , sum_plresp , rk4site%par_beam & - , rk4site%par_diffuse , rk4site%nir_beam , rk4site%nir_diffuse & - , par_b_beam , par_b_diff , nir_b_beam & - , nir_b_diff + , initp%can_theta , can_theiv , initp%can_enthalpy & + , initp%ground_temp , initp%ground_shv , avg_leaf_temp & + , sum_leaf_water , avg_wood_temp , sum_wood_water & + , initp%ggbare , initp%ggveg , initp%ggnet & + , initp%opencan_frac , initp%soil_tempk(nzg) , initp%soil_water(nzg) & + , soil8(nsoil)%soilcp , soil8(nsoil)%soilwp , soil8(nsoil)%sfldcap & + , soil8(nsoil)%slmsts , initp%ustar , initp%tstar & + , initp%qstar , initp%cstar , initp%zeta & + , initp%ribulk , fluxp%flx_rshort_gnd , fluxp%flx_rlong_gnd & + , fluxp%flx_vapor_lc , fluxp%flx_vapor_wc , fluxp%flx_vapor_gc & + , fluxp%flx_vapor_ac , fluxp%flx_transp , fluxp%flx_wshed_vg & + , fluxp%flx_intercepted , fluxp%flx_throughfall , fluxp%flx_sensible_gc & + , fluxp%flx_sensible_lc , fluxp%flx_sensible_wc , fluxp%flx_sensible_ac & + , fluxp%flx_carbon_ac , fluxp%flx_carbon_st , initp%cwd_rh & + , soil_rh , sum_gpp , sum_plresp & + , rk4site%par_beam , rk4site%par_diffuse , rk4site%nir_beam & + , rk4site%nir_diffuse , par_b_beam , par_b_diff & + , nir_b_beam , nir_b_diff close(unit=83,status='keep') !---------------------------------------------------------------------------------------! diff --git a/ED/src/dynamics/rk4_stepper.F90 b/ED/src/dynamics/rk4_stepper.F90 index 4f7f137f1..c31602d4f 100644 --- a/ED/src/dynamics/rk4_stepper.F90 +++ b/ED/src/dynamics/rk4_stepper.F90 @@ -274,7 +274,6 @@ subroutine rkck(y,dydx,yout,yerr,ak2,ak3,ak4,ak5,ak6,ak7,x,h,csite,ipa !----- Local variables --------------------------------------------------------------! type(patchtype) , pointer :: cpatch real(kind=8) :: combh - real(kind=8) :: dpdt !------------------------------------------------------------------------------------! @@ -312,14 +311,8 @@ subroutine rkck(y,dydx,yout,yerr,ak2,ak3,ak4,ak5,ak6,ak7,x,h,csite,ipa !------------------------------------------------------------------------------------! - !------ Estimate the derivative of canopy pressure. ---------------------------------! - dpdt = (ak7%can_prss - y%can_prss) / combh - dydx%can_prss = dpdt * rk4_b21 - !------------------------------------------------------------------------------------! - - !------ Get the new derivative evaluation. ------------------------------------------! - call leaf_derivs(ak7, ak2, csite, ipa) + call leaf_derivs(ak7, ak2, csite, ipa,-9000.d0) !------------------------------------------------------------------------------------! @@ -337,15 +330,8 @@ subroutine rkck(y,dydx,yout,yerr,ak2,ak3,ak4,ak5,ak6,ak7,x,h,csite,ipa !------------------------------------------------------------------------------------! - !------ Estimate the derivative of canopy pressure. ---------------------------------! - dpdt = (ak7%can_prss - y%can_prss) / combh - dydx%can_prss = dydx%can_prss + dpdt * rk4_b31 - ak2%can_prss = dpdt * rk4_b32 - !------------------------------------------------------------------------------------! - - !------ Get the new derivative evaluation. ------------------------------------------! - call leaf_derivs(ak7, ak3, csite,ipa) + call leaf_derivs(ak7, ak3, csite,ipa,-9000.d0) !------------------------------------------------------------------------------------! @@ -364,16 +350,8 @@ subroutine rkck(y,dydx,yout,yerr,ak2,ak3,ak4,ak5,ak6,ak7,x,h,csite,ipa !------------------------------------------------------------------------------------! - !------ Estimate the derivative of canopy pressure. ---------------------------------! - dpdt = (ak7%can_prss - y%can_prss) / combh - dydx%can_prss = dydx%can_prss + dpdt * rk4_b41 - ak2%can_prss = ak2%can_prss + dpdt * rk4_b42 - ak3%can_prss = dpdt * rk4_b43 - !------------------------------------------------------------------------------------! - - !------ Get the new derivative evaluation. ------------------------------------------! - call leaf_derivs(ak7, ak4, csite, ipa) + call leaf_derivs(ak7, ak4, csite, ipa,-9000.d0) !------------------------------------------------------------------------------------! @@ -393,17 +371,8 @@ subroutine rkck(y,dydx,yout,yerr,ak2,ak3,ak4,ak5,ak6,ak7,x,h,csite,ipa !------------------------------------------------------------------------------------! - !------ Estimate the derivative of canopy pressure. ---------------------------------! - dpdt = (ak7%can_prss - y%can_prss) / combh - dydx%can_prss = dydx%can_prss + dpdt * rk4_b51 - ak2%can_prss = ak2%can_prss + dpdt * rk4_b52 - ak3%can_prss = ak3%can_prss + dpdt * rk4_b53 - ak4%can_prss = dpdt * rk4_b54 - !------------------------------------------------------------------------------------! - - !------ Get the new derivative evaluation. ------------------------------------------! - call leaf_derivs(ak7, ak5, csite, ipa) + call leaf_derivs(ak7, ak5, csite, ipa,-9000.d0) !------------------------------------------------------------------------------------! @@ -424,18 +393,8 @@ subroutine rkck(y,dydx,yout,yerr,ak2,ak3,ak4,ak5,ak6,ak7,x,h,csite,ipa !------------------------------------------------------------------------------------! - !------ Estimate the derivative of canopy pressure. ---------------------------------! - dpdt = (ak7%can_prss - y%can_prss) / combh - dydx%can_prss = dydx%can_prss + dpdt * rk4_b61 - ak2%can_prss = ak2%can_prss + dpdt * rk4_b62 - ak3%can_prss = ak3%can_prss + dpdt * rk4_b63 - ak4%can_prss = ak4%can_prss + dpdt * rk4_b64 - ak5%can_prss = dpdt * rk4_b65 - !------------------------------------------------------------------------------------! - - !------ Get the new derivative evaluation. ------------------------------------------! - call leaf_derivs(ak7, ak6, csite,ipa) + call leaf_derivs(ak7, ak6, csite,ipa,-9000.d0) !------------------------------------------------------------------------------------! @@ -456,34 +415,6 @@ subroutine rkck(y,dydx,yout,yerr,ak2,ak3,ak4,ak5,ak6,ak7,x,h,csite,ipa !------------------------------------------------------------------------------------! - !------ Estimate the derivative of canopy pressure. ---------------------------------! - dpdt = (ak7%can_prss - y%can_prss) / combh - dydx%can_prss = dydx%can_prss + dpdt * rk4_c1 - ak3%can_prss = ak3%can_prss + dpdt * rk4_c3 - ak4%can_prss = ak4%can_prss + dpdt * rk4_c4 - ak6%can_prss = dpdt * rk4_c6 - !------------------------------------------------------------------------------------! - - - - !------------------------------------------------------------------------------------! - ! Average the pressure derivative estimates. ! - !------------------------------------------------------------------------------------! - dydx%can_prss = dydx%can_prss & - / (rk4_b21 + rk4_b31 + rk4_b41 + rk4_b51 + rk4_b61 + rk4_c1) - ak2%can_prss = ak2%can_prss & - / ( rk4_b32 + rk4_b42 + rk4_b52 + rk4_b62 ) - ak3%can_prss = ak3%can_prss & - / ( rk4_b43 + rk4_b53 + rk4_b63 + rk4_c3) - ak4%can_prss = ak4%can_prss & - / ( rk4_b54 + rk4_b64 + rk4_c4) - ak5%can_prss = ak5%can_prss & - / ( rk4_b65 ) - ak6%can_prss = ak6%can_prss & - / ( rk4_c6) - !------------------------------------------------------------------------------------! - - !------------------------------------------------------------------------------------! ! Estimate the error for this step. ! @@ -519,8 +450,8 @@ subroutine rk4_sanity_check(y,reject_step, csite,ipa,dydx,h,print_problems) , rk4site & ! intent(in) , rk4eps & ! intent(in) , toocold & ! intent(in) - , rk4min_can_theiv & ! intent(in) - , rk4max_can_theiv & ! intent(in) + , rk4min_can_enthalpy & ! intent(in) + , rk4max_can_enthalpy & ! intent(in) , rk4min_can_theta & ! intent(in) , rk4max_can_theta & ! intent(in) , rk4max_can_shv & ! intent(in) @@ -529,8 +460,6 @@ subroutine rk4_sanity_check(y,reject_step, csite,ipa,dydx,h,print_problems) , rk4max_can_rhv & ! intent(in) , rk4min_can_temp & ! intent(in) , rk4max_can_temp & ! intent(in) - , rk4min_can_theiv & ! intent(in) - , rk4max_can_theiv & ! intent(in) , rk4min_can_prss & ! intent(in) , rk4max_can_prss & ! intent(in) , rk4min_can_co2 & ! intent(in) @@ -589,14 +518,15 @@ subroutine rk4_sanity_check(y,reject_step, csite,ipa,dydx,h,print_problems) !------------------------------------------------------------------------------------! ! Check whether the canopy air equivalent potential temperature is off. ! !------------------------------------------------------------------------------------! - if (y%can_theiv > rk4max_can_theiv .or. y%can_theiv < rk4min_can_theiv ) then + if (y%can_enthalpy > rk4max_can_enthalpy .or. & + y%can_enthalpy < rk4min_can_enthalpy ) then reject_step = .true. if(record_err) integ_err(1,2) = integ_err(1,2) + 1_8 if (print_problems) then write(unit=*,fmt='(a)') '===========================================' - write(unit=*,fmt='(a)') ' + Canopy air theta_Eiv is off-track...' + write(unit=*,fmt='(a)') ' + Canopy air enthalpy is off-track...' write(unit=*,fmt='(a)') '-------------------------------------------' - write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THEIV: ',y%can_theiv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_ENTHALPY: ',y%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THETA: ',y%can_theta write(unit=*,fmt='(a,1x,es12.4)') ' CAN_SHV: ',y%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHV: ',y%can_rhv @@ -605,7 +535,7 @@ subroutine rk4_sanity_check(y,reject_step, csite,ipa,dydx,h,print_problems) write(unit=*,fmt='(a,1x,es12.4)') ' CAN_CO2: ',y%can_co2 write(unit=*,fmt='(a,1x,es12.4)') ' CAN_DEPTH: ',y%can_depth write(unit=*,fmt='(a,1x,es12.4)') ' CAN_PRSS: ',y%can_prss - write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_LNTHETA )/Dt:',dydx%can_lntheta + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_ENTHALPY)/Dt:',dydx%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_SHV )/Dt:',dydx%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_CO2 )/Dt:',dydx%can_co2 write(unit=*,fmt='(a)') '===========================================' @@ -628,7 +558,7 @@ subroutine rk4_sanity_check(y,reject_step, csite,ipa,dydx,h,print_problems) write(unit=*,fmt='(a)') '===========================================' write(unit=*,fmt='(a)') ' + Canopy air pot. temp. is off-track...' write(unit=*,fmt='(a)') '-------------------------------------------' - write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THEIV: ',y%can_theiv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_ENTHALPY: ',y%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THETA: ',y%can_theta write(unit=*,fmt='(a,1x,es12.4)') ' CAN_SHV: ',y%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHV: ',y%can_rhv @@ -637,7 +567,7 @@ subroutine rk4_sanity_check(y,reject_step, csite,ipa,dydx,h,print_problems) write(unit=*,fmt='(a,1x,es12.4)') ' CAN_CO2: ',y%can_co2 write(unit=*,fmt='(a,1x,es12.4)') ' CAN_DEPTH: ',y%can_depth write(unit=*,fmt='(a,1x,es12.4)') ' CAN_PRSS: ',y%can_prss - write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_LNTHETA )/Dt:',dydx%can_lntheta + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_ENTHALPY)/Dt:',dydx%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_SHV )/Dt:',dydx%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_CO2 )/Dt:',dydx%can_co2 write(unit=*,fmt='(a)') '===========================================' @@ -660,7 +590,7 @@ subroutine rk4_sanity_check(y,reject_step, csite,ipa,dydx,h,print_problems) write(unit=*,fmt='(a)') '===========================================' write(unit=*,fmt='(a)') ' + Canopy air sp. humidity is off-track...' write(unit=*,fmt='(a)') '-------------------------------------------' - write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THEIV: ',y%can_theiv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_ENTHALPY: ',y%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THETA: ',y%can_theta write(unit=*,fmt='(a,1x,es12.4)') ' CAN_SHV: ',y%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHV: ',y%can_rhv @@ -669,7 +599,7 @@ subroutine rk4_sanity_check(y,reject_step, csite,ipa,dydx,h,print_problems) write(unit=*,fmt='(a,1x,es12.4)') ' CAN_CO2: ',y%can_co2 write(unit=*,fmt='(a,1x,es12.4)') ' CAN_DEPTH: ',y%can_depth write(unit=*,fmt='(a,1x,es12.4)') ' CAN_PRSS: ',y%can_prss - write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_LNTHETA )/Dt:',dydx%can_lntheta + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_ENTHALPY)/Dt:',dydx%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_SHV )/Dt:',dydx%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_CO2 )/Dt:',dydx%can_co2 write(unit=*,fmt='(a)') '===========================================' @@ -692,7 +622,7 @@ subroutine rk4_sanity_check(y,reject_step, csite,ipa,dydx,h,print_problems) write(unit=*,fmt='(a)') '===========================================' write(unit=*,fmt='(a)') ' + Canopy air temperature is off-track...' write(unit=*,fmt='(a)') '-------------------------------------------' - write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THEIV: ',y%can_theiv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_ENTHALPY: ',y%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THETA: ',y%can_theta write(unit=*,fmt='(a,1x,es12.4)') ' CAN_SHV: ',y%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHV: ',y%can_rhv @@ -701,7 +631,7 @@ subroutine rk4_sanity_check(y,reject_step, csite,ipa,dydx,h,print_problems) write(unit=*,fmt='(a,1x,es12.4)') ' CAN_CO2: ',y%can_co2 write(unit=*,fmt='(a,1x,es12.4)') ' CAN_DEPTH: ',y%can_depth write(unit=*,fmt='(a,1x,es12.4)') ' CAN_PRSS: ',y%can_prss - write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_LNTHETA )/Dt:',dydx%can_lntheta + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_ENTHALPY)/Dt:',dydx%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_SHV )/Dt:',dydx%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_CO2 )/Dt:',dydx%can_co2 write(unit=*,fmt='(a)') '===========================================' @@ -724,7 +654,7 @@ subroutine rk4_sanity_check(y,reject_step, csite,ipa,dydx,h,print_problems) write(unit=*,fmt='(a)') '===========================================' write(unit=*,fmt='(a)') ' + Canopy air pressure is off-track...' write(unit=*,fmt='(a)') '-------------------------------------------' - write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THEIV: ',y%can_theiv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_ENTHALPY: ',y%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THETA: ',y%can_theta write(unit=*,fmt='(a,1x,es12.4)') ' CAN_SHV: ',y%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHV: ',y%can_rhv @@ -733,7 +663,7 @@ subroutine rk4_sanity_check(y,reject_step, csite,ipa,dydx,h,print_problems) write(unit=*,fmt='(a,1x,es12.4)') ' CAN_CO2: ',y%can_co2 write(unit=*,fmt='(a,1x,es12.4)') ' CAN_DEPTH: ',y%can_depth write(unit=*,fmt='(a,1x,es12.4)') ' CAN_PRSS: ',y%can_prss - write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_LNTHETA )/Dt:',dydx%can_lntheta + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_ENTHALPY)/Dt:',dydx%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_SHV )/Dt:',dydx%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_CO2 )/Dt:',dydx%can_co2 write(unit=*,fmt='(a)') '===========================================' @@ -757,7 +687,7 @@ subroutine rk4_sanity_check(y,reject_step, csite,ipa,dydx,h,print_problems) write(unit=*,fmt='(a)') '===========================================' write(unit=*,fmt='(a)') ' + Canopy air CO2 is off-track...' write(unit=*,fmt='(a)') '-------------------------------------------' - write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THEIV: ',y%can_theiv + write(unit=*,fmt='(a,1x,es12.4)') ' CAN_ENTHALPY: ',y%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' CAN_THETA: ',y%can_theta write(unit=*,fmt='(a,1x,es12.4)') ' CAN_SHV: ',y%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' CAN_RHV: ',y%can_rhv @@ -766,7 +696,7 @@ subroutine rk4_sanity_check(y,reject_step, csite,ipa,dydx,h,print_problems) write(unit=*,fmt='(a,1x,es12.4)') ' CAN_CO2: ',y%can_co2 write(unit=*,fmt='(a,1x,es12.4)') ' CAN_DEPTH: ',y%can_depth write(unit=*,fmt='(a,1x,es12.4)') ' CAN_PRSS: ',y%can_prss - write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_LNTHETA )/Dt:',dydx%can_lntheta + write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_ENTHALPY)/Dt:',dydx%can_enthalpy write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_SHV )/Dt:',dydx%can_shv write(unit=*,fmt='(a,1x,es12.4)') ' D(CAN_CO2 )/Dt:',dydx%can_co2 write(unit=*,fmt='(a)') '===========================================' @@ -803,7 +733,6 @@ subroutine rk4_sanity_check(y,reject_step, csite,ipa,dydx,h,print_problems) write(unit=*,fmt='(a,1x,es12.4)') ' HEIGHT: ',cpatch%hite(ico) write(unit=*,fmt='(a,1x,es12.4)') ' LAI: ',y%lai(ico) write(unit=*,fmt='(a,1x,es12.4)') ' WAI: ',y%wai(ico) - write(unit=*,fmt='(a,1x,es12.4)') ' WPA: ',y%wpa(ico) write(unit=*,fmt='(a,1x,es12.4)') ' TAI: ',y%tai(ico) write(unit=*,fmt='(a,1x,es12.4)') ' NPLANT: ',y%nplant(ico) write(unit=*,fmt='(a,1x,es12.4)') ' CROWN_AREA: ',y%crown_area(ico) @@ -842,7 +771,6 @@ subroutine rk4_sanity_check(y,reject_step, csite,ipa,dydx,h,print_problems) write(unit=*,fmt='(a,1x,es12.4)') ' HEIGHT: ',cpatch%hite(ico) write(unit=*,fmt='(a,1x,es12.4)') ' LAI: ',y%lai(ico) write(unit=*,fmt='(a,1x,es12.4)') ' WAI: ',y%wai(ico) - write(unit=*,fmt='(a,1x,es12.4)') ' WPA: ',y%wpa(ico) write(unit=*,fmt='(a,1x,es12.4)') ' TAI: ',y%tai(ico) write(unit=*,fmt='(a,1x,es12.4)') ' NPLANT: ',y%nplant(ico) write(unit=*,fmt='(a,1x,es12.4)') ' CROWN_AREA: ',y%crown_area(ico) @@ -898,7 +826,6 @@ subroutine rk4_sanity_check(y,reject_step, csite,ipa,dydx,h,print_problems) write(unit=*,fmt='(a,1x,es12.4)') ' HEIGHT: ',cpatch%hite(ico) write(unit=*,fmt='(a,1x,es12.4)') ' LAI: ',y%lai(ico) write(unit=*,fmt='(a,1x,es12.4)') ' WAI: ',y%wai(ico) - write(unit=*,fmt='(a,1x,es12.4)') ' WPA: ',y%wpa(ico) write(unit=*,fmt='(a,1x,es12.4)') ' TAI: ',y%tai(ico) write(unit=*,fmt='(a,1x,es12.4)') ' NPLANT: ',y%nplant(ico) write(unit=*,fmt='(a,1x,es12.4)') ' CROWN_AREA: ',y%crown_area(ico) @@ -937,7 +864,6 @@ subroutine rk4_sanity_check(y,reject_step, csite,ipa,dydx,h,print_problems) write(unit=*,fmt='(a,1x,es12.4)') ' HEIGHT: ',cpatch%hite(ico) write(unit=*,fmt='(a,1x,es12.4)') ' LAI: ',y%lai(ico) write(unit=*,fmt='(a,1x,es12.4)') ' WAI: ',y%wai(ico) - write(unit=*,fmt='(a,1x,es12.4)') ' WPA: ',y%wpa(ico) write(unit=*,fmt='(a,1x,es12.4)') ' TAI: ',y%tai(ico) write(unit=*,fmt='(a,1x,es12.4)') ' NPLANT: ',y%nplant(ico) write(unit=*,fmt='(a,1x,es12.4)') ' CROWN_AREA: ',y%crown_area(ico) @@ -1155,16 +1081,16 @@ subroutine rk4_sanity_check(y,reject_step, csite,ipa,dydx,h,print_problems) write(unit=*,fmt='(a)') ' ' write(unit=*,fmt='(a)') ' 1. CANOPY AIR SPACE: ' write(unit=*,fmt='(a)') ' ' - write(unit=*,fmt='(6(a,1x))') ' MIN_THEIV',' MAX_THEIV',' MIN_SHV' & - ,' MAX_SHV',' MIN_RHV',' MAX_RHV' - write(unit=*,fmt='(6(es12.5,1x))') rk4min_can_theiv,rk4max_can_theiv & - ,rk4min_can_shv ,rk4max_can_shv & + write(unit=*,fmt='(4(a,1x))') ' MIN_SHV',' MAX_SHV',' MIN_RHV' & + ,' MAX_RHV' + write(unit=*,fmt='(4(es12.5,1x))') rk4min_can_shv ,rk4max_can_shv & ,rk4min_can_rhv ,rk4max_can_rhv write(unit=*,fmt='(a)') ' ' - write(unit=*,fmt='(4(a,1x))') ' MIN_TEMP',' MAX_TEMP',' MIN_THETA' & - ,' MAX_THETA' - write(unit=*,fmt='(4(es12.5,1x))') rk4min_can_temp ,rk4max_can_temp & - ,rk4min_can_theta,rk4max_can_theta + write(unit=*,fmt='(6(a,1x))') ' MIN_TEMP',' MAX_TEMP',' MIN_THETA' & + ,' MAX_THETA','MIN_ENTHALPY','MAX_ENTHALPY' + write(unit=*,fmt='(6(es12.5,1x))') rk4min_can_temp ,rk4max_can_temp & + ,rk4min_can_theta ,rk4max_can_theta & + ,rk4min_can_enthalpy,rk4max_can_enthalpy write(unit=*,fmt='(a)') ' ' write(unit=*,fmt='(4(a,1x))') ' MIN_PRSS',' MAX_PRSS',' MIN_CO2' & ,' MAX_CO2' @@ -1272,30 +1198,28 @@ subroutine print_sanity_check(y, csite, ipa) write(unit=*,fmt='(a)') ' ' write(unit=*,fmt='(78a)') ('-',k=1,78) cpatch => csite%patch(ipa) - write (unit=*,fmt='(2(a5,1x),8(a12,1x))') & - ' COH',' PFT',' LAI',' WAI',' WPA',' TAI' & - ,' LEAF_ENERGY',' OLD_LEAF_EN',' LEAF_TEMP','OLD_LEAF_TMP' + write (unit=*,fmt='(2(a5,1x),7(a12,1x))') & + ' COH',' PFT',' LAI',' WAI',' TAI',' LEAF_ENERGY' & + ,' OLD_LEAF_EN',' LEAF_TEMP','OLD_LEAF_TMP' do ico = 1,cpatch%ncohorts if(y%leaf_resolvable(ico)) then - write(unit=*,fmt='(2(i5,1x),8(es12.4,1x))') & - ico,cpatch%pft(ico),y%lai(ico),y%wai(ico),y%wpa(ico),y%tai(ico) & - ,y%leaf_energy(ico),cpatch%leaf_energy(ico),y%leaf_temp(ico) & - ,cpatch%leaf_temp(ico) + write(unit=*,fmt='(2(i5,1x),7(es12.4,1x))') & + ico,cpatch%pft(ico),y%lai(ico),y%wai(ico),y%tai(ico),y%leaf_energy(ico) & + ,cpatch%leaf_energy(ico),y%leaf_temp(ico),cpatch%leaf_temp(ico) end if end do write(unit=*,fmt='(78a)') ('-',k=1,78) write(unit=*,fmt='(a)') ' ' write(unit=*,fmt='(78a)') ('-',k=1,78) - write (unit=*,fmt='(2(a5,1x),8(a12,1x))') & - ' COH',' PFT',' LAI',' WAI',' WPA',' TAI' & - ,' LEAF_WATER','OLD_LEAF_H2O',' LEAF_HCAP',' LEAF_FLIQ' + write (unit=*,fmt='(2(a5,1x),7(a12,1x))') & + ' COH',' PFT',' LAI',' WAI',' TAI',' LEAF_WATER' & + ,'OLD_LEAF_H2O',' LEAF_HCAP',' LEAF_FLIQ' do ico = 1,cpatch%ncohorts if(y%leaf_resolvable(ico)) then - write(unit=*,fmt='(2(i5,1x),8(es12.4,1x))') & - ico,cpatch%pft(ico),y%lai(ico),y%wai(ico),y%wpa(ico),y%tai(ico) & - ,y%leaf_water(ico),cpatch%leaf_water(ico),cpatch%leaf_hcap(ico) & - ,y%leaf_hcap(ico) + write(unit=*,fmt='(2(i5,1x),7(es12.4,1x))') & + ico,cpatch%pft(ico),y%lai(ico),y%wai(ico),y%tai(ico),y%leaf_water(ico) & + ,cpatch%leaf_water(ico),cpatch%leaf_hcap(ico),y%leaf_hcap(ico) end if end do write(unit=*,fmt='(78a)') ('-',k=1,78) @@ -1304,30 +1228,28 @@ subroutine print_sanity_check(y, csite, ipa) write(unit=*,fmt='(a)') ' ' write(unit=*,fmt='(78a)') ('-',k=1,78) cpatch => csite%patch(ipa) - write (unit=*,fmt='(2(a5,1x),8(a12,1x))') & - ' COH',' PFT',' LAI',' WAI',' WPA',' TAI' & - ,' WOOD_ENERGY',' OLD_WOOD_EN',' WOOD_TEMP','OLD_WOOD_TMP' + write (unit=*,fmt='(2(a5,1x),7(a12,1x))') & + ' COH',' PFT',' LAI',' WAI',' TAI',' WOOD_ENERGY' & + ,' OLD_WOOD_EN',' WOOD_TEMP','OLD_WOOD_TMP' do ico = 1,cpatch%ncohorts if(y%wood_resolvable(ico)) then - write(unit=*,fmt='(2(i5,1x),8(es12.4,1x))') & - ico,cpatch%pft(ico),y%lai(ico),y%wai(ico),y%wpa(ico),y%tai(ico) & - ,y%wood_energy(ico),cpatch%wood_energy(ico),y%wood_temp(ico) & - ,cpatch%wood_temp(ico) + write(unit=*,fmt='(2(i5,1x),7(es12.4,1x))') & + ico,cpatch%pft(ico),y%lai(ico),y%wai(ico),y%tai(ico),y%wood_energy(ico) & + ,cpatch%wood_energy(ico),y%wood_temp(ico),cpatch%wood_temp(ico) end if end do write(unit=*,fmt='(78a)') ('-',k=1,78) write(unit=*,fmt='(a)') ' ' write(unit=*,fmt='(78a)') ('-',k=1,78) - write (unit=*,fmt='(2(a5,1x),8(a12,1x))') & - ' COH',' PFT',' LAI',' WAI',' WPA',' TAI' & - ,' WOOD_WATER','OLD_WOOD_H2O',' WOOD_HCAP',' WOOD_FLIQ' + write (unit=*,fmt='(2(a5,1x),7(a12,1x))') & + ' COH',' PFT',' LAI',' WAI',' TAI',' WOOD_WATER' & + ,'OLD_WOOD_H2O',' WOOD_HCAP',' WOOD_FLIQ' do ico = 1,cpatch%ncohorts if(y%wood_resolvable(ico)) then - write(unit=*,fmt='(2(i5,1x),8(es12.4,1x))') & - ico,cpatch%pft(ico),y%lai(ico),y%wai(ico),y%wpa(ico),y%tai(ico) & - ,y%wood_water(ico),cpatch%wood_water(ico),cpatch%wood_hcap(ico) & - ,y%wood_hcap(ico) + write(unit=*,fmt='(2(i5,1x),7(es12.4,1x))') & + ico,cpatch%pft(ico),y%lai(ico),y%wai(ico),y%tai(ico),y%wood_water(ico) & + ,cpatch%wood_water(ico),cpatch%wood_hcap(ico),y%wood_hcap(ico) end if end do write(unit=*,fmt='(78a)') ('-',k=1,78) diff --git a/ED/src/dynamics/structural_growth.f90 b/ED/src/dynamics/structural_growth.f90 index 216072ad7..1dd84f809 100644 --- a/ED/src/dynamics/structural_growth.f90 +++ b/ED/src/dynamics/structural_growth.f90 @@ -23,6 +23,7 @@ subroutine structural_growth(cgrid, month) use decomp_coms , only : f_labile ! ! intent(in) use ed_max_dims , only : n_pft & ! intent(in) , n_dbh ! ! intent(in) + use ed_misc_coms , only : ibigleaf ! ! intent(in) use ed_therm_lib , only : calc_veg_hcap & ! function , update_veg_energy_cweh ! ! function implicit none @@ -126,12 +127,14 @@ subroutine structural_growth(cgrid, month) cpatch%bdead(ico) = cpatch%bdead(ico) + f_bdead * cpatch%bstorage(ico) - !------ NPP allocation to wood and course roots in KgC /m2 -----------------! - cpatch%today_NPPwood(ico) = agf_bs(ipft) * f_bdead * cpatch%bstorage(ico) & - * cpatch%nplant(ico) - cpatch%today_NPPcroot(ico) = (1. - agf_bs(ipft)) * f_bdead & - * cpatch%bstorage(ico) * cpatch%nplant(ico) - + if (ibigleaf == 0 ) then + !------ NPP allocation to wood and course roots in KgC /m2 --------------! + cpatch%today_NPPwood(ico) = agf_bs(ipft)*f_bdead*cpatch%bstorage(ico) & + * cpatch%nplant(ico) + cpatch%today_NPPcroot(ico) = (1. - agf_bs(ipft)) * f_bdead & + * cpatch%bstorage(ico) * cpatch%nplant(ico) + end if + !---------------------------------------------------------------------------! ! Rebalance the plant nitrogen uptake considering the actual alloc- ! ! ation to structural growth. This is necessary because c2n_stem does not ! @@ -502,6 +505,7 @@ subroutine plant_structural_allocation(ipft,hite,dbh,lat,phen_status,f_bseeds,f_ , dbh_crit & ! intent(in) , is_grass ! ! intent(in) use ed_misc_coms , only : current_time ! ! intent(in) + use ed_misc_coms , only : ibigleaf ! ! intent(in) implicit none !----- Arguments -----------------------------------------------------------------------! integer , intent(in) :: ipft @@ -546,32 +550,58 @@ subroutine plant_structural_allocation(ipft,hite,dbh,lat,phen_status,f_bseeds,f_ - !---------------------------------------------------------------------------------------! - ! Calculate fraction of bstorage going to bdead and reproduction. First we must ! - ! make sure that the plant should do something here. A plant should not allocate any- ! - ! thing to reproduction or growth if it is not the right time of year (for cold ! - ! deciduous plants), or if the plants are actively dropping leaves or off allometry. ! - !---------------------------------------------------------------------------------------! - if ((phenology(ipft) /= 2 .or. late_spring) .and. phen_status == 0) then - if (is_grass(ipft) .and. dbh >= dbh_crit(ipft)) then + select case (ibigleaf) + case (0) + !------------------------------------------------------------------------------------! + ! Size and age structure. Calculate fraction of bstorage going to bdead and ! + ! reproduction. First we must make sure that the plant should do something here. A ! + ! plant should not allocate anything to reproduction or growth if it is not the ! + ! right time of year (for cold deciduous plants), or if the plants are actively ! + ! dropping leaves or off allometry. ! + !------------------------------------------------------------------------------------! + if ((phenology(ipft) /= 2 .or. late_spring) .and. phen_status == 0) then + if (is_grass(ipft) .and. dbh >= dbh_crit(ipft)) then + !---------------------------------------------------------------------------------! + ! Grasses have reached the maximum height, stop growing in size and send ! + ! everything to reproduction. ! + !---------------------------------------------------------------------------------! + f_bseeds = 1.0 - st_fract(ipft) + elseif (hite <= repro_min_h(ipft)) then + !----- The plant is too short, invest as much as it can in growth. ---------------! + f_bseeds = 0.0 + else + !----- Plant is with a certain height, use prescribed reproduction rate. ---------! + f_bseeds = r_fract(ipft) + end if + f_bdead = 1.0 - st_fract(ipft) - f_bseeds + else + f_bdead = 0.0 + f_bseeds = 0.0 + end if + !------------------------------------------------------------------------------------! + case (1) + !------------------------------------------------------------------------------------! + ! Big-leaf solver. As long as it is OK to grow, everything goes into 'reproduct- ! + ! ion'. This will ultimately be used to increase NPLANT of the 'big leaf' cohort. ! + !------------------------------------------------------------------------------------! + if ((phenology(ipft) /= 2 .or. late_spring) .and. phen_status == 0) then !---------------------------------------------------------------------------------! - ! Grasses have reached the maximum height, stop growing in size and send ! - ! everything to reproduction. ! + ! A plant should only grow if it is the right time of year (for cold deciduous ! + ! plants), or if the plants are not actively dropping leaves or off allometry. ! !---------------------------------------------------------------------------------! f_bseeds = 1.0 - st_fract(ipft) - elseif (hite <= repro_min_h(ipft)) then - !----- The plant is too short, invest as much as it can in growth. ---------------! - f_bseeds = 0.0 + f_bdead = 0.0 else - !----- Plant is with a certain height, use prescribed reproduction rate. ---------! - f_bseeds = r_fract(ipft) - end if - f_bdead = 1.0 - st_fract(ipft) - f_bseeds - else - f_bdead = 0.0 - f_bseeds = 0.0 - end if - + f_bdead = 0.0 + f_bseeds = 0.0 + end if + end select + !---------------------------------------------------------------------------------------! + + + + + !---------------------------------------------------------------------------------------! if (printout) then open (unit=66,file=fracfile,status='old',position='append',action='write') write (unit=66,fmt='(6(i12,1x),2(11x,l1,1x),7(f12.4,1x))') & @@ -643,7 +673,7 @@ subroutine update_derived_cohort_props(cpatch,ico,green_leaf_factor,lsl) ! If LEAF biomass is not the maximum, set it to 1 (leaves partially flushed), ! ! otherwise, set it to 0 (leaves are fully flushed). ! !------------------------------------------------------------------------------------! - if (cpatch%bleaf(ico) < bl_max) then + if (cpatch%bleaf(ico) < bl_max .or. cpatch%elongf(ico) < 1.0) then cpatch%phenology_status(ico) = 1 else cpatch%phenology_status(ico) = 0 @@ -651,11 +681,11 @@ subroutine update_derived_cohort_props(cpatch,ico,green_leaf_factor,lsl) end select - !----- Update LAI, WPA, and WAI --------------------------------------------------------! + !----- Update LAI, WAI, and CAI. -------------------------------------------------------! call area_indices(cpatch%nplant(ico),cpatch%bleaf(ico),cpatch%bdead(ico) & ,cpatch%balive(ico),cpatch%dbh(ico), cpatch%hite(ico),cpatch%pft(ico) & - ,cpatch%sla(ico),cpatch%lai(ico),cpatch%wpa(ico),cpatch%wai(ico) & - ,cpatch%crown_area(ico),cpatch%bsapwood(ico)) + ,cpatch%sla(ico),cpatch%lai(ico),cpatch%wai(ico),cpatch%crown_area(ico) & + ,cpatch%bsapwood(ico)) !----- Finding the new basal area and above-ground biomass. ----------------------------! cpatch%basarea(ico) = pio4 * cpatch%dbh(ico) * cpatch%dbh(ico) diff --git a/ED/src/dynamics/vegetation_dynamics.f90 b/ED/src/dynamics/vegetation_dynamics.f90 index 55bd68a76..3549051cd 100644 --- a/ED/src/dynamics/vegetation_dynamics.f90 +++ b/ED/src/dynamics/vegetation_dynamics.f90 @@ -8,31 +8,35 @@ subroutine vegetation_dynamics(new_month,new_year) use grid_coms , only : ngrids use ed_misc_coms , only : current_time & ! intent(in) , dtlsm & ! intent(in) - , frqsum ! ! intent(in) - use disturb_coms , only : include_fire ! ! intent(in) + , frqsum & ! intent(in) + , ibigleaf ! ! intent(in) use disturbance_utils, only : apply_disturbances & ! subroutine , site_disturbance_rates ! ! subroutine - use fuse_fiss_utils , only : fuse_patches ! ! subroutine + use fuse_fiss_utils , only : fuse_patches & ! subroutine + , terminate_patches & ! subroutine + , rescale_patches ! ! subroutine use ed_state_vars , only : edgrid_g & ! intent(inout) - , edtype ! ! variable type + , edtype & ! variable type + , polygontype ! ! variable type use growth_balive , only : dbalive_dt ! ! subroutine use consts_coms , only : day_sec & ! intent(in) , yr_day ! ! intent(in) use mem_polygons , only : maxpatch ! ! intent(in) implicit none !----- Arguments. ----------------------------------------------------------------------! - logical , intent(in) :: new_month - logical , intent(in) :: new_year + logical , intent(in) :: new_month + logical , intent(in) :: new_year !----- Local variables. ----------------------------------------------------------------! - type(edtype), pointer :: cgrid - real :: tfact1 - real :: tfact2 - integer :: doy - integer :: ip - integer :: isite - integer :: ifm + type(edtype) , pointer :: cgrid + type(polygontype), pointer :: cpoly + real :: tfact1 + real :: tfact2 + integer :: doy + integer :: ipy + integer :: isi + integer :: ifm !----- External functions. -------------------------------------------------------------! - integer , external :: julday + integer , external :: julday !---------------------------------------------------------------------------------------! !----- Find the day of year. -----------------------------------------------------------! @@ -106,11 +110,41 @@ subroutine vegetation_dynamics(new_month,new_year) !------------------------------------------------------------------------------------! - ! Fuse patches last, after all updates have been applied. This reduces the ! - ! number of patch variables that actually need to be fused. ! + ! Patch dynamics. ! !------------------------------------------------------------------------------------! - if(new_year) then - if (maxpatch >= 0) call fuse_patches(cgrid,ifm) + if (new_year) then + select case(ibigleaf) + case (0) + !------------------------------------------------------------------------------! + ! Size and age structure. Fuse patches last, after all updates have been ! + ! applied. This reduces the number of patch variables that actually need to ! + ! be fused. After fusing, we also check whether there are patches that are ! + ! too small, and terminate them. ! + !------------------------------------------------------------------------------! + if (maxpatch >= 0) call fuse_patches(cgrid,ifm) + do ipy = 1,cgrid%npolygons + cpoly => cgrid%polygon(ipy) + + do isi = 1, cpoly%nsites + call terminate_patches(cpoly%site(isi)) + end do + end do + !------------------------------------------------------------------------------! + + case (1) + !------------------------------------------------------------------------------! + ! Big leaf. All that we do is rescale the patches. ! + !------------------------------------------------------------------------------! + do ipy = 1,cgrid%npolygons + cpoly => cgrid%polygon(ipy) + + do isi = 1, cpoly%nsites + call rescale_patches(cpoly%site(isi)) + end do + end do + !------------------------------------------------------------------------------! + end select + !---------------------------------------------------------------------------------! end if !------------------------------------------------------------------------------------! @@ -144,7 +178,6 @@ subroutine vegetation_dynamics_eq_0(new_month,new_year) use ed_misc_coms , only : current_time & ! intent(in) , dtlsm & ! intent(in) , frqsum ! ! intent(in) - use disturb_coms , only : include_fire ! ! intent(in) use disturbance_utils, only : apply_disturbances & ! subroutine , site_disturbance_rates ! ! subroutine use fuse_fiss_utils , only : fuse_patches ! ! subroutine @@ -164,8 +197,6 @@ subroutine vegetation_dynamics_eq_0(new_month,new_year) real :: tfact1 real :: tfact2 integer :: doy - integer :: ip - integer :: isite integer :: ifm !----- External functions. -------------------------------------------------------------! integer , external :: julday diff --git a/ED/src/init/ed_init.f90 b/ED/src/init/ed_init.f90 index d77b46e63..8dab8618a 100644 --- a/ED/src/init/ed_init.f90 +++ b/ED/src/init/ed_init.f90 @@ -290,7 +290,8 @@ end subroutine soil_depth_fill !------------------------------------------------------------------------------------------! subroutine load_ecosystem_state() use phenology_coms , only : iphen_scheme ! ! intent(in) - use ed_misc_coms , only : ied_init_mode ! ! intent(in) + use ed_misc_coms , only : ied_init_mode & ! intent(in) + , ibigleaf ! ! intent(in) use phenology_startup , only : phenology_init ! ! intent(in) use ed_node_coms , only : mynum & ! intent(in) , nmachs & ! intent(in) @@ -354,23 +355,38 @@ subroutine load_ecosystem_state() select case (ied_init_mode) - case(-8,-1,0) - !----- Initialize everything with near-bare ground ----------------------------------! - if (mynum /= 1) write(unit=*,fmt='(a)') ' + Doing near bare ground initialization...' - do igr=1,ngrids - call near_bare_ground_init(edgrid_g(igr)) - end do + case (-8,-1,0) + + select case (ibigleaf) + case (0) + !----- Initialize everything with near-bare ground -------------------------------! + if (mynum /= 1) then + write (unit=*,fmt='(a)') ' + Doing near bare ground initialization...' + end if + do igr=1,ngrids + call near_bare_ground_init(edgrid_g(igr)) + end do + + case (1) + !----- Initialize everything with near-bare ground -------------------------------! + if (mynum /= 1) then + write(unit=*,fmt='(a)') ' + Doing near-bare-ground big-leaf initialization...' + end if + do igr=1,ngrids + call near_bare_ground_big_leaf_init(edgrid_g(igr)) + end do + end select - case(1,2,3,6) + case (1,2,3,6) !----- Initialize with ED1-type restart information. --------------------------------! write(unit=*,fmt='(a,i3.3)') ' + Initializing from ED restart file. Node: ',mynum call read_ed10_ed20_history_file - case(4) + case (4) write(unit=*,fmt='(a,i3.3)') ' + Initializing from ED2.1 state file. Node: ',mynum call read_ed21_history_file - case(5,99) + case (5,99) write(unit=*,fmt='(a,i3.3)') & ' + Initializing from a collection of ED2.1 state files. Node: ',mynum call read_ed21_history_unstruct diff --git a/ED/src/init/ed_init_atm.F90 b/ED/src/init/ed_init_atm.F90 index 078b7f48f..5d87f52e6 100644 --- a/ED/src/init/ed_init_atm.F90 +++ b/ED/src/init/ed_init_atm.F90 @@ -4,7 +4,8 @@ ! conditions plus some soil parameters. ! !------------------------------------------------------------------------------------------! subroutine ed_init_atm() - use ed_misc_coms , only : runtype ! ! intent(in) + use ed_misc_coms , only : runtype & ! intent(in) + , ibigleaf ! ! intent(in) use ed_state_vars , only : edtype & ! structure , polygontype & ! structure , sitetype & ! structure @@ -16,18 +17,13 @@ subroutine ed_init_atm() , slmstr & ! intent(in) , stgoff & ! intent(in) , ed_soil_idx2water ! ! intent(in) - use consts_coms , only : tsupercool & ! intent(in) - , cliqvlme & ! intent(in) - , cicevlme & ! intent(in) - , t3ple & ! intent(in) - , cp & ! intent(in) - , alvl & ! intent(in) - , p00i & ! intent(in) - , rocp ! ! intent(in) + use consts_coms , only : wdns & ! intent(in) + , t3ple ! ! intent(in) use grid_coms , only : nzs & ! intent(in) , nzg & ! intent(in) , ngrids ! ! intent(in) use fuse_fiss_utils , only : fuse_patches & ! subroutine + , rescale_patches & ! subroutine , fuse_cohorts & ! subroutine , terminate_cohorts & ! subroutine , split_cohorts ! ! subroutine @@ -40,8 +36,11 @@ subroutine ed_init_atm() , ed_grndvap ! ! subroutine use therm_lib , only : thetaeiv & ! function , idealdenssh & ! function - , rslif & ! function - , reducedpress ! ! function + , qslif & ! function + , reducedpress & ! function + , press2exner & ! function + , extheta2temp & ! function + , cmtl2uext ! ! function use met_driver_coms , only : met_driv_state ! ! structure use canopy_struct_dynamics, only : canopy_turbulence ! ! subroutine implicit none @@ -71,6 +70,7 @@ subroutine ed_init_atm() real :: poly_nplant real :: elim_nplant real :: elim_lai + real :: can_exner real :: rvaux !----- Add the MPI common block. -------------------------------------------------------! include 'mpif.h' @@ -120,11 +120,14 @@ subroutine ed_init_atm() csite%can_prss (ipa) = reducedpress(cmet%prss,cmet%atm_theta,cmet%atm_shv & ,cmet%geoht,csite%can_theta(ipa) & ,csite%can_shv(ipa),csite%can_depth(ipa)) - csite%can_temp (ipa) = csite%can_theta(ipa) & - * (p00i *csite%can_prss(ipa)) ** rocp + can_exner = press2exner(csite%can_prss(ipa)) + csite%can_temp (ipa) = extheta2temp(can_exner,csite%can_theta(ipa)) + csite%can_temp_pv(ipa)=csite%can_temp(ipa) rvaux = csite%can_shv(ipa) / (1. - csite%can_shv(ipa)) + + csite%can_theiv(ipa) = thetaeiv(csite%can_theta(ipa),csite%can_prss(ipa) & - ,csite%can_temp(ipa),rvaux,rvaux,-10) + ,csite%can_temp(ipa),rvaux,rvaux) csite%can_rhos (ipa) = idealdenssh(csite%can_prss(ipa) & ,csite%can_temp(ipa),csite%can_shv(ipa)) @@ -146,22 +149,37 @@ subroutine ed_init_atm() ! thermal equilibrium with the canopy air space and no intercepted ! ! water sitting on top of leaves and branches. ! !------------------------------------------------------------------------! - cpatch%leaf_temp (ico) = csite%can_temp(ipa) - cpatch%leaf_fliq (ico) = 0.0 cpatch%leaf_water (ico) = 0.0 - cpatch%wood_temp (ico) = csite%can_temp(ipa) - cpatch%wood_fliq (ico) = 0.0 cpatch%wood_water (ico) = 0.0 + cpatch%leaf_temp (ico) = csite%can_temp(ipa) + cpatch%wood_temp (ico) = csite%can_temp(ipa) + cpatch%leaf_temp_pv (ico) = csite%can_temp_pv(ipa) + cpatch%wood_temp_pv (ico) = csite%can_temp_pv(ipa) + if (csite%can_temp(ipa) == t3ple) then + cpatch%leaf_fliq (ico) = 0.5 + cpatch%wood_fliq (ico) = 0.5 + elseif (csite%can_temp(ipa) > t3ple) then + cpatch%leaf_fliq (ico) = 1.0 + cpatch%wood_fliq (ico) = 1.0 + else + cpatch%leaf_fliq (ico) = 0.0 + cpatch%wood_fliq (ico) = 0.0 + end if - call calc_veg_hcap(cpatch%bleaf(ico),cpatch%bdead(ico) & - ,cpatch%bsapwood(ico),cpatch%nplant(ico) & - ,cpatch%pft(ico) & - ,cpatch%leaf_hcap(ico),cpatch%wood_hcap(ico) ) - - cpatch%leaf_energy (ico) = cpatch%leaf_hcap(ico) * cpatch%leaf_temp(ico) - cpatch%wood_energy (ico) = cpatch%wood_hcap(ico) * cpatch%wood_temp(ico) - + call calc_veg_hcap( cpatch%bleaf (ico) , cpatch%bdead (ico) & + , cpatch%bsapwood (ico) , cpatch%nplant (ico) & + , cpatch%pft (ico) , cpatch%leaf_hcap(ico) & + , cpatch%wood_hcap (ico) ) + + cpatch%leaf_energy (ico) = cmtl2uext( cpatch%leaf_hcap (ico) & + , cpatch%leaf_water (ico) & + , cpatch%leaf_temp (ico) & + , cpatch%leaf_fliq (ico) ) + cpatch%wood_energy (ico) = cmtl2uext( cpatch%wood_hcap (ico) & + , cpatch%wood_water (ico) & + , cpatch%wood_temp (ico) & + , cpatch%wood_fliq (ico) ) call is_resolvable(csite,ipa,ico,cpoly%green_leaf_factor(:,isi)) @@ -172,12 +190,15 @@ subroutine ed_init_atm() cpatch%lsfc_co2_closed(ico) = cmet%atm_co2 cpatch%lint_co2_open(ico) = cmet%atm_co2 cpatch%lint_co2_closed(ico) = cmet%atm_co2 + !------------------------------------------------------------------------! + + !------------------------------------------------------------------------! ! The intercellular specific humidity is assumed to be at ! ! saturation. ! !------------------------------------------------------------------------! - cpatch%lint_shv(ico) = rslif(csite%can_prss(ipa),cpatch%leaf_temp(ico)) - cpatch%lint_shv(ico) = cpatch%lint_shv(ico) / (1. + cpatch%lint_shv(ico)) + cpatch%lint_shv(ico) = qslif(csite%can_prss(ipa),cpatch%leaf_temp(ico)) + !------------------------------------------------------------------------! end do cohortloop1 end do patchloop1 end do siteloop1 @@ -232,25 +253,33 @@ subroutine ed_init_atm() if (csite%soil_tempk(1,ipa) == -100.0 .or. isoilstateinit == 0) then groundloop2: do k = 1, nzg + nsoil=cpoly%ntext_soil(k,isi) + + !----- Find the initial temperature. ---------------------------------! csite%soil_tempk(k,ipa) = csite%can_temp(ipa) + stgoff(k) + !---------------------------------------------------------------------! + !------ Find the soil liquid fraction based on the temperature. ------! if (csite%soil_tempk(k,ipa) > t3ple) then nsoil=cpoly%ntext_soil(k,isi) csite%soil_fracliq(k,ipa) = 1.0 - csite%soil_water(k,ipa) = ed_soil_idx2water(slmstr(k),nsoil) - csite%soil_energy(k,ipa) = soil(nsoil)%slcpd & - * csite%soil_tempk(k,ipa) & - + csite%soil_water(k,ipa) * cliqvlme & - * (csite%soil_tempk(k,ipa) - tsupercool) - else - nsoil=cpoly%ntext_soil(k,isi) + elseif (csite%soil_tempk(k,ipa) < t3ple) then csite%soil_fracliq(k,ipa) = 0.0 - csite%soil_water(k,ipa) = ed_soil_idx2water(slmstr(k),nsoil) - csite%soil_energy(k,ipa) = soil(nsoil)%slcpd & - * csite%soil_tempk(k,ipa) & - + csite%soil_water(k,ipa) & - * cicevlme * csite%soil_tempk(k,ipa) + else + csite%soil_fracliq(k,ipa) = 0.5 end if + !---------------------------------------------------------------------! + + + !---------------------------------------------------------------------! + ! Initialise soil moisture and internal energy. ! + !---------------------------------------------------------------------! + csite%soil_water(k,ipa) = ed_soil_idx2water(slmstr(k),nsoil) + csite%soil_energy(k,ipa) = cmtl2uext( soil(nsoil)%slcpd & + , csite%soil_water(k,ipa)*wdns & + , csite%soil_tempk(k,ipa) & + , csite%soil_fracliq(k,ipa) ) + !---------------------------------------------------------------------! end do groundloop2 !----- Initial condition is with no snow/pond. --------------------------! @@ -310,51 +339,108 @@ subroutine ed_init_atm() call update_polygon_derived_props(cgrid) !----- Fuse similar patches to speed up the run. ------------------------------------! - call fuse_patches(cgrid,igr) - - !------------------------------------------------------------------------------------! - ! Loop over all polygons/sites/patches, and fuse/split/terminate cohorts as ! - ! needed. ! - !------------------------------------------------------------------------------------! - polyloop3: do ipy = 1,cgrid%npolygons - ncohorts = 0 - npatches = 0 - poly_lai = 0.0 - poly_nplant = 0.0 - - cpoly => cgrid%polygon(ipy) - poly_area_i = 1./sum(cpoly%area(:)) + select case(ibigleaf) + case (0) + !---------------------------------------------------------------------------------! + ! Size and age structure. Start by fusing similar patches. ! + !---------------------------------------------------------------------------------! + call fuse_patches(cgrid,igr) + !---------------------------------------------------------------------------------! - siteloop3: do isi = 1,cpoly%nsites - csite => cpoly%site(isi) - site_area_i = 1./sum(csite%area(:)) - patchloop3: do ipa = 1,csite%npatches - npatches = npatches + 1 - cpatch => csite%patch(ipa) + !---------------------------------------------------------------------------------! + ! Loop over all polygons/sites/patches, and fuse/split/terminate cohorts as ! + ! needed. ! + !---------------------------------------------------------------------------------! + polyloop3: do ipy = 1,cgrid%npolygons + ncohorts = 0 + npatches = 0 + poly_lai = 0.0 + poly_nplant = 0.0 + + cpoly => cgrid%polygon(ipy) + poly_area_i = 1./sum(cpoly%area(:)) + + siteloop3: do isi = 1,cpoly%nsites + csite => cpoly%site(isi) + site_area_i = 1./sum(csite%area(:)) + + patchloop3: do ipa = 1,csite%npatches + npatches = npatches + 1 + cpatch => csite%patch(ipa) + + if (cpatch%ncohorts > 0) then + call fuse_cohorts(csite,ipa,cpoly%green_leaf_factor(:,isi) & + ,cpoly%lsl(isi)) + call terminate_cohorts(csite,ipa,elim_nplant,elim_lai) + call split_cohorts(cpatch,cpoly%green_leaf_factor(:,isi) & + ,cpoly%lsl(isi)) + end if + + cohortloop3: do ico = 1,cpatch%ncohorts + ncohorts=ncohorts+1 + poly_lai = poly_lai + cpatch%lai(ico) * csite%area(ipa) & + * cpoly%area(isi) * site_area_i * poly_area_i + poly_nplant = poly_nplant + cpatch%nplant(ico) * csite%area(ipa) & + * cpoly%area(isi) * site_area_i & + * poly_area_i + end do cohortloop3 + end do patchloop3 + end do siteloop3 + + write(unit = * & + ,fmt = '(2(a,1x,i6,1x),2(a,1x,f9.4,1x),2(a,1x,f7.2,1x),2(a,1x,i4,1x))') & + 'Grid:',igr,'Poly:',ipy,'Lon:',cgrid%lon(ipy),'Lat: ',cgrid%lat(ipy) & + ,'Nplants:',poly_nplant,'Avg. LAI:',poly_lai & + ,'NPatches:',npatches,'NCohorts:',ncohorts + end do polyloop3 + !---------------------------------------------------------------------------------! - if (cpatch%ncohorts > 0) then - call fuse_cohorts(csite,ipa,cpoly%green_leaf_factor(:,isi),cpoly%lsl(isi)) - call terminate_cohorts(csite,ipa,elim_nplant,elim_lai) - call split_cohorts(cpatch,cpoly%green_leaf_factor(:,isi), cpoly%lsl(isi)) - end if - cohortloop3: do ico = 1,cpatch%ncohorts - ncohorts=ncohorts+1 - poly_lai = poly_lai + cpatch%lai(ico) * csite%area(ipa) & + case (1) + !---------------------------------------------------------------------------------! + ! Big leaf. No need to do anything, just print the banner. ! + !---------------------------------------------------------------------------------! + polyloop4: do ipy = 1,cgrid%npolygons + ncohorts = 0 + npatches = 0 + poly_lai = 0.0 + poly_nplant = 0.0 + + cpoly => cgrid%polygon(ipy) + poly_area_i = 1./sum(cpoly%area(:)) + + siteloop4: do isi = 1,cpoly%nsites + csite => cpoly%site(isi) + site_area_i = 1./sum(csite%area(:)) + + !call rescale_patches(csite) + + patchloop4: do ipa = 1,csite%npatches + npatches = npatches + 1 + cpatch => csite%patch(ipa) + + cohortloop4: do ico = 1,cpatch%ncohorts + ncohorts=ncohorts+1 + poly_lai = poly_lai + cpatch%lai(ico) * csite%area(ipa) & * cpoly%area(isi) * site_area_i * poly_area_i - poly_nplant = poly_nplant + cpatch%nplant(ico) * csite%area(ipa) & - * cpoly%area(isi) * site_area_i * poly_area_i - end do cohortloop3 - end do patchloop3 - end do siteloop3 - - write(unit=*,fmt='(2(a,1x,i6,1x),2(a,1x,f9.4,1x),2(a,1x,f7.2,1x),2(a,1x,i4,1x))') & - 'Grid:',igr,'Poly:',ipy,'Lon:',cgrid%lon(ipy),'Lat: ',cgrid%lat(ipy) & - ,'Nplants:',poly_nplant,'Avg. LAI:',poly_lai & - ,'NPatches:',npatches,'NCohorts:',ncohorts - end do polyloop3 + poly_nplant = poly_nplant + cpatch%nplant(ico) * csite%area(ipa) & + * cpoly%area(isi) * site_area_i * poly_area_i + end do cohortloop4 + end do patchloop4 + end do siteloop4 + + write( unit = * & + , fmt = '(2(a,1x,i6,1x),2(a,1x,f9.4,1x),2(a,1x,f7.2,1x),2(a,1x,i4,1x))') & + 'Grid:',igr,'Poly:',ipy,'Lon:',cgrid%lon(ipy),'Lat: ',cgrid%lat(ipy) & + ,'Nplants:',poly_nplant,'Avg. LAI:',poly_lai & + ,'NPatches:',npatches,'NCohorts:',ncohorts + end do polyloop4 + !---------------------------------------------------------------------------------! + end select + !------------------------------------------------------------------------------------! end do gridloop + !---------------------------------------------------------------------------------------! return end subroutine ed_init_atm diff --git a/ED/src/init/ed_nbg_init.f90 b/ED/src/init/ed_nbg_init.f90 index 866d895d6..281fea13e 100644 --- a/ED/src/init/ed_nbg_init.f90 +++ b/ED/src/init/ed_nbg_init.f90 @@ -221,12 +221,11 @@ subroutine init_nbg_cohorts(csite,lsl,ipa_a,ipa_z) cpatch%bstorage(ico) = 0.5 * ( cpatch%bleaf(ico) + cpatch%broot(ico) & + cpatch%bsapwood(ico)) - !----- Find the initial area indices (LAI, WPA, WAI). ----------------------------! + !----- Find the initial area indices (LAI, WAI, CAI). ----------------------------! call area_indices(cpatch%nplant(ico),cpatch%bleaf(ico),cpatch%bdead(ico) & ,cpatch%balive(ico),cpatch%dbh(ico), cpatch%hite(ico) & ,cpatch%pft(ico),cpatch%sla(ico),cpatch%lai(ico) & - ,cpatch%wpa(ico),cpatch%wai(ico),cpatch%crown_area(ico) & - ,cpatch%bsapwood(ico)) + ,cpatch%wai(ico),cpatch%crown_area(ico),cpatch%bsapwood(ico)) !----- Find the above-ground biomass and basal area. -----------------------------! cpatch%agb(ico) = ed_biomass(cpatch%bdead(ico),cpatch%balive(ico) & @@ -361,12 +360,11 @@ subroutine init_cohorts_by_layers(csite,lsl,ipa_a,ipa_z) !----- NPlant is defined such that the cohort LAI is equal to LAI0 cpatch%nplant(ico) = lai0 / (cpatch%bleaf(ico) * cpatch%sla(ico)) - !----- Find the initial area indices (LAI, WPA, WAI). ----------------------------! + !----- Find the initial area indices (LAI, WAI, CAI). ----------------------------! call area_indices(cpatch%nplant(ico),cpatch%bleaf(ico),cpatch%bdead(ico) & ,cpatch%balive(ico),cpatch%dbh(ico), cpatch%hite(ico) & ,cpatch%pft(ico),cpatch%sla(ico),cpatch%lai(ico) & - ,cpatch%wpa(ico),cpatch%wai(ico),cpatch%crown_area(ico) & - ,cpatch%bsapwood(ico)) + ,cpatch%wai(ico),cpatch%crown_area(ico),cpatch%bsapwood(ico)) !----- Find the above-ground biomass and basal area. -----------------------------! cpatch%agb(ico) = ed_biomass(cpatch%bdead(ico),cpatch%balive(ico) & @@ -393,3 +391,187 @@ subroutine init_cohorts_by_layers(csite,lsl,ipa_a,ipa_z) end subroutine init_cohorts_by_layers !==========================================================================================! !==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +! This subroutine initializes a near-bare ground 'big-leaf' ed run. ! +!------------------------------------------------------------------------------------------! +subroutine near_bare_ground_big_leaf_init(cgrid) + use ed_state_vars , only : edtype & ! structure + , polygontype & ! structure + , sitetype & ! structure + , patchtype & ! structure + , allocate_sitetype & ! subroutine + , allocate_patchtype! ! subroutine + use ed_misc_coms , only : ied_init_mode & ! intent(in) + , ibigleaf ! ! intent(in) + use physiology_coms, only : n_plant_lim ! ! intent(in) + use grid_coms , only : nzg ! ! intent(in) + use pft_coms , only : q & ! intent(in) + , qsw & ! intent(in) + , sla & ! intent(in) + , hgt_min & ! intent(in) + , include_pft & ! intent(in) + , include_these_pft & ! intent(in) + , include_pft_ag & ! intent(in) + , init_density ! ! intent(in) + use consts_coms , only : t3ple & ! intent(in) + , pio4 & ! intent(in) + , kgom2_2_tonoha& ! intent(in) + , tonoha_2_kgom2! ! intent(in) + use allometry , only : h2dbh & ! function + , dbh2bd & ! function + , dbh2bl & ! function + , ed_biomass & ! function + , area_indices ! ! subroutine + implicit none + + !----- Arguments. ----------------------------------------------------------------------! + type(edtype) , target :: cgrid + !----- Local variables. ----------------------------------------------------------------! + type(polygontype) , pointer :: cpoly + type(sitetype) , pointer :: csite + type(patchtype) , pointer :: cpatch ! Current patch + integer :: ipy ! Patch counter + integer :: ico ! Cohort counter + integer :: isi ! Site counter + integer :: ipa + integer :: k + integer :: mypfts ! Number of included PFTs + integer :: ipft ! PFT counter + real :: salloc ! balive/bleaf when on allom. + real :: salloci ! 1./salloc + !---------------------------------------------------------------------------------------! + + + !----- Big loop ------------------------------------------------------------------------! + polyloop: do ipy=1,cgrid%npolygons + cpoly => cgrid%polygon(ipy) + siteloop: do isi=1,cpoly%nsites + csite => cpoly%site(isi) + + !-- Figure out how many patches (1 patch per pft), always primary vegetation. ----! + select case (ied_init_mode) + case (-1) !------ True bare ground simulation (absolute desert). -----------------! + mypfts = 1 + case ( 0) !------ Nearly bare ground simulation (start with a few seedlings). ----! + mypfts = count(include_pft) + end select + csite%npatches = mypfts + + call allocate_sitetype(csite,mypfts) + + !----- Patch loop ---------------------------------------------------------------! + patchloop: do ipa=1, csite%npatches + cpatch => csite%patch(ipa) + ipft = include_these_pft(ipa) + + csite%dist_type (ipa) = 3 + csite%age (ipa) = 0.0 + csite%area (ipa) = 1.0 / mypfts + + select case (n_plant_lim) + case (0) + csite%fast_soil_C (ipa) = 0.0 + csite%slow_soil_C (ipa) = 0.0 + csite%structural_soil_C (ipa) = 0.0 + csite%structural_soil_L (ipa) = 0.0 + csite%mineralized_soil_N (ipa) = 0.0 + csite%fast_soil_N (ipa) = 0.0 + + case (1) + csite%fast_soil_C (ipa) = 0.2 + csite%slow_soil_C (ipa) = 0.01 + csite%structural_soil_C (ipa) = 10.0 + csite%structural_soil_L (ipa) = csite%structural_soil_C (1) + csite%mineralized_soil_N (ipa) = 1.0 + csite%fast_soil_N (ipa) = 1.0 + + end select + !------------------------------------------------------------------------------! + + csite%sum_dgd (ipa) = 0.0 + csite%sum_chd (ipa) = 0.0 + csite%plantation (ipa) = 0 + csite%plant_ag_biomass (ipa) = 0. + + !------------------------------------------------------------------------------! + ! We now populate the cohorts with near bare ground condition. In case of ! + ! a desert, we initialise with an empty patch, otherwise we add one cohort per ! + ! patch. ! + !------------------------------------------------------------------------------! + select case (ied_init_mode) + case (-1) + call allocate_patchtype(cpatch,0) + case default + ico = 1 + + call allocate_patchtype(cpatch,1) + !----- The PFT is the plant functional type. -------------------------------! + cpatch%pft(ico) = ipft + + !---------------------------------------------------------------------------! + ! Define the near-bare ground state using the standard minimum height ! + ! and minimum plant density. We assume all NBG PFTs to have leaves fully ! + ! flushed, but with no storage biomass. We then compute the other biomass ! + ! quantities using the standard allometry for this PFT. ! + !---------------------------------------------------------------------------! + cpatch%nplant(ico) = init_density(ipft) + cpatch%hite(ico) = hgt_min(ipft) + cpatch%phenology_status(ico) = 0 + cpatch%bstorage(ico) = 0.0 + cpatch%dbh(ico) = h2dbh(cpatch%hite(ico),ipft) + cpatch%bdead(ico) = dbh2bd(cpatch%dbh(ico),ipft) + cpatch%bleaf(ico) = dbh2bl(cpatch%dbh(ico),ipft) + cpatch%sla(ico) = sla(ipft) + + salloc = 1.0 + q(ipft) + qsw(ipft) * cpatch%hite(ico) + salloci = 1. / salloc + + cpatch%balive(ico) = cpatch%bleaf(ico) * salloc + cpatch%broot(ico) = q(ipft) * cpatch%balive(ico) * salloci + cpatch%bsapwood(ico) = qsw(ipft) * cpatch%hite(ico) & + * cpatch%balive(ico) * salloci + + !----- Find the initial area indices (LAI, WAI, CAI). ----------------------! + call area_indices(cpatch%nplant(ico),cpatch%bleaf(ico),cpatch%bdead(ico) & + ,cpatch%balive(ico),cpatch%dbh(ico), cpatch%hite(ico) & + ,cpatch%pft(ico),cpatch%sla(ico),cpatch%lai(ico) & + ,cpatch%wai(ico),cpatch%crown_area(ico) & + ,cpatch%bsapwood(ico)) + + !----- Find the above-ground biomass and basal area. -----------------------! + cpatch%agb(ico) = ed_biomass(cpatch%bdead(ico),cpatch%balive(ico) & + ,cpatch%bleaf(ico),cpatch%pft(ico) & + ,cpatch%hite(ico),cpatch%bstorage(ico) & + ,cpatch%bsapwood(ico)) + cpatch%basarea(ico) = pio4 * cpatch%dbh(ico)*cpatch%dbh(ico) + + !----- Initialize other cohort-level variables. ----------------------------! + call init_ed_cohort_vars(cpatch,ico,cpoly%lsl(isi)) + + !----- Update total patch-level above-ground biomass -----------------------! + csite%plant_ag_biomass(ipa) = csite%plant_ag_biomass(ipa) & + + cpatch%nplant(ico) * cpatch%agb(ico) + end select + end do patchloop + + !----- Initialise the patches now that cohorts are there. ------------------------! + call init_ed_patch_vars(csite,1,csite%npatches,cpoly%lsl(isi)) + end do siteloop + !----- Initialise some site-level variables. ----------------------------------------! + call init_ed_site_vars(cpoly,cgrid%lat(ipy)) + end do polyloop + + !----- Last, but not the least, the polygons. ------------------------------------------! + call init_ed_poly_vars(cgrid) + + return +end subroutine near_bare_ground_big_leaf_init +!==========================================================================================! +!==========================================================================================! diff --git a/ED/src/init/ed_params.f90 b/ED/src/init/ed_params.f90 index fa0cb5c4a..ca72a7b93 100644 --- a/ED/src/init/ed_params.f90 +++ b/ED/src/init/ed_params.f90 @@ -1037,8 +1037,8 @@ subroutine init_can_air_params() ! is used to calculate the heat and moisture storage capacity in ! ! the canopy air space. ! !---------------------------------------------------------------------------------------! - veg_height_min = minval(hgt_min) ! alternative: minval(hgt_min) - minimum_canopy_depth = 1.5 ! alternative: minval(hgt_min) + veg_height_min = minval(hgt_min) + minimum_canopy_depth = 5.0 ! alternative: minval(hgt_min) !----- This is the dimensionless exponential wind atenuation factor. -------------------! exar = 2.5 @@ -1330,7 +1330,8 @@ end subroutine init_can_air_params ! cohorts (or when both must be considered). ! !------------------------------------------------------------------------------------------! subroutine init_can_lyr_params() - use canopy_layer_coms, only : ncanlyr & ! intent(out) + use canopy_layer_coms, only : tai_lyr_max & ! intent(out) + , ncanlyr & ! intent(out) , ncanlyrp1 & ! intent(out) , ncanlyrt2 & ! intent(out) , zztop0 & ! intent(out) @@ -1360,6 +1361,13 @@ subroutine init_can_lyr_params() !---------------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------------! + ! Set the maximum tai that each layer is allowed to have. ! + !---------------------------------------------------------------------------------------! + tai_lyr_max = 1.0 + !---------------------------------------------------------------------------------------! + + !----- Find the layer thickness and the number of layers needed. -----------------------! ncanlyr = 100 @@ -1535,7 +1543,7 @@ subroutine init_pft_photo_params() Vm0(11) = 6.981875 * vmfact_c3 Vm0(12:13) = 18.300000 * vmfact_c3 Vm0(14:15) = 12.500000 * vmfact_c4 - Vm0(16) = 25.000000 * vmfact_c3 + Vm0(16) = 21.875000 * vmfact_c3 Vm0(17) = 15.625000 * vmfact_c3 !---------------------------------------------------------------------------------------! @@ -1573,7 +1581,7 @@ subroutine init_pft_photo_params() dark_respiration_factor(14) = gamma_c3 dark_respiration_factor(15) = gamma_c3 dark_respiration_factor(16) = gamma_c3 - dark_respiration_factor(17) = gamma_c3 * 0.028 / 0.020 + dark_respiration_factor(17) = gamma_c3 * 1.2 !---------------------------------------------------------------------------------------! @@ -1801,7 +1809,7 @@ subroutine init_pft_resp_params() growth_resp_factor(16) = growthresp growth_resp_factor(17) = 0.4503 - leaf_turnover_rate(1) = 4.0 + leaf_turnover_rate(1) = 3.0 leaf_turnover_rate(2) = 1.0 leaf_turnover_rate(3) = 0.5 leaf_turnover_rate(4) = onethird @@ -1814,9 +1822,9 @@ subroutine init_pft_resp_params() leaf_turnover_rate(11) = 0.0 leaf_turnover_rate(12) = 2.0 leaf_turnover_rate(13) = 2.0 - leaf_turnover_rate(14) = 2.0 - leaf_turnover_rate(15) = 2.0 - leaf_turnover_rate(16) = 4.0 + leaf_turnover_rate(14) = 3.0 + leaf_turnover_rate(15) = 3.0 + leaf_turnover_rate(16) = 3.0 leaf_turnover_rate(17) = onesixth !----- Root turnover rate. ------------------------------------------------------------! @@ -1938,6 +1946,7 @@ subroutine init_pft_mort_params() use consts_coms , only : t00 & ! intent(in) , lnexp_max & ! intent(in) , twothirds ! ! intent(in) + use ed_misc_coms, only : ibigleaf ! ! intent(in) use disturb_coms, only : treefall_disturbance_rate & ! intent(inout) , time2canopy ! ! intent(in) @@ -2081,10 +2090,10 @@ subroutine init_pft_mort_params() !---------------------------------------------------------------------------------------! ! Here we check whether patches should be created or the treefall should affect ! - ! only the mortality (quasi- size-structured approximation; other disturbances may be ! - ! turned off for a true size-structured approximation). ! + ! only the mortality (big leaf or quasi- size-structured approximation; other ! + ! disturbances may be turned off for a true size-structured approximation). ! !---------------------------------------------------------------------------------------! - if (treefall_disturbance_rate < 0.) then + if (treefall_disturbance_rate < 0. .or. ibigleaf == 1) then !------------------------------------------------------------------------------------! ! We incorporate the disturbance rate into the density-independent mortality ! ! rate and turn off the patch-creating treefall disturbance. ! @@ -2122,8 +2131,8 @@ subroutine init_pft_mort_params() plant_min_temp(10:11) = t00-20.0 plant_min_temp(12:13) = t00-80.0 plant_min_temp(14:15) = t00+2.5 - plant_min_temp(16) = t00-10.0 - plant_min_temp(17) = t00-10.0 + plant_min_temp(16) = t00-20.0 + plant_min_temp(17) = t00-15.0 return end subroutine init_pft_mort_params @@ -2139,57 +2148,64 @@ end subroutine init_pft_mort_params !==========================================================================================! subroutine init_pft_alloc_params() - use pft_coms , only : leaf_turnover_rate & ! intent(in) - , is_tropical & ! intent(out) - , is_grass & ! intent(out) - , rho & ! intent(out) - , SLA & ! intent(out) - , horiz_branch & ! intent(out) - , q & ! intent(out) - , qsw & ! intent(out) - , init_density & ! intent(out) - , agf_bs & ! intent(out) - , brf_wd & ! intent(out) - , hgt_min & ! intent(out) - , hgt_ref & ! intent(out) - , hgt_max & ! intent(out) - , min_dbh & ! intent(out) - , dbh_crit & ! intent(out) - , min_bdead & ! intent(out) - , bdead_crit & ! intent(out) - , b1Ht & ! intent(out) - , b2Ht & ! intent(out) - , b1Bs_small & ! intent(out) - , b2Bs_small & ! intent(out) - , b1Bs_large & ! intent(out) - , b2Bs_large & ! intent(out) - , b1Ca & ! intent(out) - , b2Ca & ! intent(out) - , b1Rd & ! intent(out) - , b2Rd & ! intent(out) - , b1Vol & ! intent(out) - , b2Vol & ! intent(out) - , b1Bl & ! intent(out) - , b2Bl & ! intent(out) - , b1WAI & ! intent(out) - , b2WAI & ! intent(out) - , C2B & ! intent(out) - , sla_scale & ! intent(out) - , sla_inter & ! intent(out) - , sla_slope & ! intent(out) - , sapwood_ratio ! ! intent(out) - use allometry , only : h2dbh & ! function - , dbh2bd ! ! function - use consts_coms , only : twothirds & ! intent(in) - , pi1 ! ! intent(in) - use ed_max_dims , only : n_pft & ! intent(in) - , str_len ! ! intent(in) - use ed_misc_coms, only : iallom ! ! intent(in) + use pft_coms , only : leaf_turnover_rate & ! intent(in) + , is_tropical & ! intent(out) + , is_grass & ! intent(out) + , rho & ! intent(out) + , SLA & ! intent(out) + , horiz_branch & ! intent(out) + , q & ! intent(out) + , qsw & ! intent(out) + , init_density & ! intent(out) + , init_laimax & ! intent(out) + , agf_bs & ! intent(out) + , brf_wd & ! intent(out) + , hgt_min & ! intent(out) + , hgt_ref & ! intent(out) + , hgt_max & ! intent(out) + , min_dbh & ! intent(out) + , dbh_crit & ! intent(out) + , min_bdead & ! intent(out) + , bdead_crit & ! intent(out) + , b1Ht & ! intent(out) + , b2Ht & ! intent(out) + , b1Bs_small & ! intent(out) + , b2Bs_small & ! intent(out) + , b1Bs_large & ! intent(out) + , b2Bs_large & ! intent(out) + , b1Ca & ! intent(out) + , b2Ca & ! intent(out) + , b1Rd & ! intent(out) + , b2Rd & ! intent(out) + , b1Vol & ! intent(out) + , b2Vol & ! intent(out) + , b1Bl & ! intent(out) + , b2Bl & ! intent(out) + , b1WAI & ! intent(out) + , b2WAI & ! intent(out) + , C2B & ! intent(out) + , sla_scale & ! intent(out) + , sla_inter & ! intent(out) + , sla_slope & ! intent(out) + , sapwood_ratio ! ! intent(out) + use allometry , only : h2dbh & ! function + , dbh2bd & ! function + , dbh2bl ! ! function + use consts_coms , only : twothirds & ! intent(in) + , huge_num & ! intent(in) + , pi1 ! ! intent(in) + use ed_max_dims , only : n_pft & ! intent(in) + , str_len ! ! intent(in) + use ed_misc_coms , only : iallom & ! intent(in) + , ibigleaf ! ! intent(in) + use detailed_coms, only : idetailed ! ! intent(in) implicit none !----- Local variables. ----------------------------------------------------------------! integer :: ipft integer :: n real :: aux + real :: init_bleaf + logical :: write_allom !----- Constants shared by both bdead and bleaf (tropical PFTs) ------------------------! real , parameter :: a1 = -1.981 real , parameter :: b1 = 1.047 @@ -2223,19 +2239,23 @@ subroutine init_pft_alloc_params() ! The "z" parameters were obtaining by using the original balive and computing ! ! bdead as the difference between the total biomass and the original balive. ! !---------------------------------------------------------------------------------------! - real, dimension(3) , parameter :: odead_small = (/-1.1138270, 2.4404830, 2.1806320/) - real, dimension(3) , parameter :: odead_large = (/ 0.1362546, 2.4217390, 6.9483532/) - real, dimension(3) , parameter :: ndead_small = (/-1.8822770, 2.4407750, 1.0082490/) - real, dimension(3) , parameter :: ndead_large = (/-1.8229460, 2.4259890, 1.0011870/) - real, dimension(3) , parameter :: nleaf = (/-2.5108071, 1.2818788, 0.5912507/) + real, dimension(3) , parameter :: odead_small = (/-1.1138270, 2.4404830, 2.1806320 /) + real, dimension(3) , parameter :: odead_large = (/ 0.1362546, 2.4217390, 6.9483532 /) + real, dimension(3) , parameter :: ndead_small = (/-1.2639530, 2.4323610, 1.8018010 /) + real, dimension(3) , parameter :: ndead_large = (/-0.8346805, 2.4255736, 2.6822805 /) + real, dimension(3) , parameter :: nleaf = (/ 0.0192512, 0.9749494, 2.5858509 /) real, dimension(2) , parameter :: ncrown_area = (/ 0.1184295, 1.0521197 /) !----- Other constants. ----------------------------------------------------------------! - logical , parameter :: write_allom = .false. character(len=str_len), parameter :: allom_file = 'allom_param.txt' !---------------------------------------------------------------------------------------! + !----- Check whether to print the allometry table or not. ------------------------------! + write_allom = btest(idetailed,5) + !---------------------------------------------------------------------------------------! + + !----- Carbon-to-biomass ratio of plant tissues. ---------------------------------------! C2B = 2.0 !---------------------------------------------------------------------------------------! @@ -2300,7 +2320,7 @@ subroutine init_pft_alloc_params() sla_slope = -0.46 !----- [KIM] - new tropical parameters. ------------------------------------------------! - SLA( 1) = 10.0**(sla_inter + sla_slope * log10(12.0/leaf_turnover_rate( 1))) * sla_scale + SLA( 1) = 21.0 ! 10.0**(sla_inter + sla_slope * log10(12.0/leaf_turnover_rate( 1))) * sla_scale SLA( 2) = 10.0**(sla_inter + sla_slope * log10(12.0/leaf_turnover_rate( 2))) * sla_scale SLA( 3) = 10.0**(sla_inter + sla_slope * log10(12.0/leaf_turnover_rate( 3))) * sla_scale SLA( 4) = 10.0**(sla_inter + sla_slope * log10(12.0/leaf_turnover_rate( 4))) * sla_scale @@ -2313,9 +2333,9 @@ subroutine init_pft_alloc_params() SLA(11) = 60.0 SLA(12) = 22.0 SLA(13) = 22.0 - SLA(14) = 10.0**(sla_inter + sla_slope * log10(12.0/leaf_turnover_rate(14))) * sla_scale - SLA(15) = 10.0**(sla_inter + sla_slope * log10(12.0/leaf_turnover_rate(15))) * sla_scale - SLA(16) = 10.0**(sla_inter + sla_slope * log10(12.0/leaf_turnover_rate(16))) * sla_scale + SLA(14) = 21.0 ! 10.0**(sla_inter + sla_slope * log10(12.0/leaf_turnover_rate(14))) * sla_scale + SLA(15) = 21.0 ! 10.0**(sla_inter + sla_slope * log10(12.0/leaf_turnover_rate(15))) * sla_scale + SLA(16) = 21.0 ! 10.0**(sla_inter + sla_slope * log10(12.0/leaf_turnover_rate(16))) * sla_scale SLA(17) = 10.0 !---------------------------------------------------------------------------------------! @@ -2374,22 +2394,6 @@ subroutine init_pft_alloc_params() - !---------------------------------------------------------------------------------------! - ! Initial density of plants, for near-bare-ground simulations [# of individuals/m2] ! - !---------------------------------------------------------------------------------------! - init_density(1) = 0.1 - init_density(2:4) = 0.1 - init_density(5) = 0.1 - init_density(6:8) = 0.1 - init_density(9:11) = 0.1 - init_density(12:13) = 0.1 - init_density(14:15) = 0.1 - init_density(16) = 0.1 - init_density(17) = 0.1 - !---------------------------------------------------------------------------------------! - - - !---------------------------------------------------------------------------------------! ! DBH/height allometry parameters. ! ! ! @@ -2569,7 +2573,7 @@ subroutine init_pft_alloc_params() b2Bl(ipft) = C2B * b2l + c2l * b2Ht(ipft) + aux case (2) !---- Based on modified Chave et al. (2001) allometry. ------------------------! - b1Bl(ipft) = C2B * exp(nleaf(1) + nleaf(3) * log(rho(ipft))) + b1Bl(ipft) = C2B * exp(nleaf(1)) * rho(ipft) / nleaf(3) b2Bl(ipft) = nleaf(2) end select end if @@ -2641,9 +2645,9 @@ subroutine init_pft_alloc_params() case (2) !---- Based an alternative modification of Chave et al. (2001) allometry. -----! - b1Bs_small(ipft) = C2B * exp(ndead_small(1) + ndead_small(3) * log(rho(ipft))) + b1Bs_small(ipft) = C2B * exp(ndead_small(1)) * rho(ipft) / ndead_small(3) b2Bs_small(ipft) = ndead_small(2) - b1Bs_large(ipft) = C2B * exp(ndead_large(1) + ndead_large(3) * log(rho(ipft))) + b1Bs_large(ipft) = C2B * exp(ndead_large(1)) * rho(ipft) / ndead_large(3) b2Bs_large(ipft) = ndead_large(2) end select @@ -2711,20 +2715,22 @@ subroutine init_pft_alloc_params() ! didn't develop the allometry, but the original reference is in German...) ! !---------------------------------------------------------------------------------------! !----- Intercept. ----------------------------------------------------------------------! - b1WAI(1) = 0.0 ! No WAI for grasses + b1WAI(1) = 0.0192 * 0.5 ! Tiny WAI for grasses b1WAI(2:4) = 0.0192 * 0.5 ! Broadleaf - b1WAI(5) = 0.0 ! No WAI for grasses + b1WAI(5) = 0.0 ! Tiny WAI for grasses b1WAI(6:8) = 0.0553 * 0.5 ! Needleleaf b1WAI(9:11) = 0.0192 * 0.5 ! Broadleaf - b1WAI(12:16) = 0.0 ! No WAI for grasses + b1WAI(12:13) = 0.0 ! Tiny WAI for grasses + b1WAI(14:16) = 0.0192 * 0.5 ! Tiny WAI for grasses b1WAI(17) = 0.0553 * 0.5 ! Needleleaf !----- Slope. --------------------------------------------------------------------------! - b2WAI(1) = 1.0 ! No WAI for grasses + b2WAI(1) = 2.0947 ! Tiny WAI for grasses b2WAI(2:4) = 2.0947 ! Broadleaf - b2WAI(5) = 1.0 ! No WAI for grasses + b2WAI(5) = 1.0 ! Tiny WAI for grasses b2WAI(6:8) = 1.9769 ! Needleleaf b2WAI(9:11) = 2.0947 ! Broadleaf - b2WAI(12:16) = 1.0 ! No WAI for grasses + b2WAI(12:13) = 1.0 ! Tiny WAI for grasses + b2WAI(14:16) = 2.0947 ! Tiny WAI for grasses b2WAI(17) = 1.9769 ! Needleleaf !---------------------------------------------------------------------------------------! @@ -2791,26 +2797,75 @@ subroutine init_pft_alloc_params() end select !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! Initial density of plants, for near-bare-ground simulations [# of individuals/m2] ! + !---------------------------------------------------------------------------------------! + select case (ibigleaf) + case (0) + !----- Size and age structure. -----------------------------------------------------! + select case (iallom) + case (0,1) + init_density(1) = 1.0 + init_density(2:4) = 1.0 + init_density(5) = 0.1 + init_density(6:8) = 0.1 + init_density(9:11) = 0.1 + init_density(12:13) = 0.1 + init_density(14:15) = 0.1 + init_density(16) = 1.0 + init_density(17) = 1.0 + case (2) + init_density(1) = 0.1 + init_density(2:4) = 0.1 + init_density(5) = 0.1 + init_density(6:8) = 0.1 + init_density(9:11) = 0.1 + init_density(12:13) = 0.1 + init_density(14:15) = 0.1 + init_density(16) = 0.1 + init_density(17) = 0.1 + end select + + !----- Define a non-sense number. --------------------------------------------------! + init_laimax(1:17) = huge_num + + case(1) + !----- Big leaf. 1st we set the maximum initial LAI for each PFT. ------------------! + init_laimax(1:17) = 0.1 + do ipft=1,n_pft + init_bleaf = dbh2bl(dbh_crit(ipft),ipft) + init_density(ipft) = init_laimax(ipft) / (init_bleaf * SLA(ipft)) + end do + !-----------------------------------------------------------------------------------! + end select + !---------------------------------------------------------------------------------------! + + if (write_allom) then open (unit=18,file=trim(allom_file),status='replace',action='write') - write(unit=18,fmt='(260a)') ('-',n=1,260) - write(unit=18,fmt='(20(1x,a))') ' PFT',' Tropical',' Grass' & + write(unit=18,fmt='(299a)') ('-',n=1,299) + write(unit=18,fmt='(23(1x,a))') ' PFT',' Tropical',' Grass' & ,' Rho',' b1Ht',' b2Ht' & ,' Hgt_ref',' b1Bl',' b2Bl' & ,' b1Bs_Small',' b2Bs_Small',' b1Bs_Large' & ,' b1Bs_Large',' b1Ca',' b2Ca' & ,' Hgt_min',' Hgt_max',' Min_DBH' & - ,' DBH_Crit',' Bdead_Crit' - write(unit=18,fmt='(260a)') ('-',n=1,260) + ,' DBH_Crit',' Bdead_Crit',' Init_dens' & + ,' Init_LAImax',' SLA' + + write(unit=18,fmt='(299a)') ('-',n=1,299) do ipft=1,n_pft - write (unit=18,fmt='(8x,i5,2(12x,l1),17(1x,es12.5))') & + write (unit=18,fmt='(8x,i5,2(12x,l1),20(1x,es12.5))') & ipft,is_tropical(ipft),is_grass(ipft),rho(ipft),b1Ht(ipft) & ,b2Ht(ipft),hgt_ref(ipft),b1Bl(ipft),b2Bl(ipft),b1Bs_small(ipft) & ,b2Bs_small(ipft),b1Bs_large(ipft),b2Bs_large(ipft),b1Ca(ipft) & ,b2Ca(ipft),hgt_min(ipft),hgt_max(ipft),min_dbh(ipft) & - ,dbh_crit(ipft),bdead_crit(ipft) + ,dbh_crit(ipft),bdead_crit(ipft),init_density(ipft) & + ,init_laimax(ipft),sla(ipft) end do - write(unit=18,fmt='(260a)') ('-',n=1,260) + write(unit=18,fmt='(299a)') ('-',n=1,299) close(unit=18,status='keep') end if @@ -2974,11 +3029,11 @@ end subroutine init_pft_leaf_params !------------------------------------------------------------------------------------------! subroutine init_pft_repro_params() - use pft_coms , only : r_fract & ! intent(out) - , st_fract & ! intent(out) - , seed_rain & ! intent(out) - , nonlocal_dispersal & ! intent(out) - , repro_min_h ! ! intent(out) + use pft_coms, only : r_fract & ! intent(out) + , st_fract & ! intent(out) + , seed_rain & ! intent(out) + , nonlocal_dispersal & ! intent(out) + , repro_min_h ! ! intent(out) implicit none r_fract(1) = 0.3 @@ -3010,6 +3065,10 @@ subroutine init_pft_repro_params() nonlocal_dispersal(9) = 1.000 ! 1.000 nonlocal_dispersal(10) = 0.325 ! 0.325 nonlocal_dispersal(11) = 0.074 ! 0.074 + nonlocal_dispersal(12) = 1.000 ! 1.000 + nonlocal_dispersal(13) = 1.000 ! 1.000 + nonlocal_dispersal(14) = 1.000 ! 1.000 + nonlocal_dispersal(15) = 1.000 ! 1.000 nonlocal_dispersal(16) = 1.000 ! 1.000 nonlocal_dispersal(17) = 0.766 ! 0.600 @@ -3038,6 +3097,7 @@ end subroutine init_pft_repro_params !------------------------------------------------------------------------------------------! subroutine init_pft_derived_params() use decomp_coms , only : f_labile ! ! intent(in) + use detailed_coms , only : idetailed ! ! intent(in) use ed_max_dims , only : n_pft & ! intent(in) , str_len ! ! intent(in) use consts_coms , only : onesixth & ! intent(in) @@ -3055,33 +3115,47 @@ subroutine init_pft_derived_params() , pft_name16 & ! intent(in) , hgt_max & ! intent(in) , dbh_crit & ! intent(in) + , one_plant_c & ! intent(out) , min_recruit_size & ! intent(out) , min_cohort_size & ! intent(out) , negligible_nplant & ! intent(out) , c2n_recruit & ! intent(out) - , lai_min ! ! intent(out) + , veg_hcap_min ! ! intent(out) use phenology_coms , only : elongf_min ! ! intent(in) use allometry , only : h2dbh & ! function , dbh2h & ! function , dbh2bl & ! function , dbh2bd ! ! function + use ed_therm_lib , only : calc_veg_hcap ! ! function implicit none !----- Local variables. ----------------------------------------------------------------! integer :: ipft real :: dbh real :: huge_dbh real :: huge_height - real :: balive_min real :: bleaf_min + real :: broot_min + real :: bsapwood_min + real :: balive_min real :: bdead_min - real :: balive_max real :: bleaf_max + real :: broot_max + real :: bsapwood_max + real :: balive_max real :: bdead_max + real :: leaf_hcap_min + real :: wood_hcap_min + real :: lai_min real :: min_plant_dens - logical , parameter :: print_zero_table = .false. - character(len=str_len), parameter :: zero_table_fn = 'minimum.size.txt' + logical :: print_zero_table + character(len=str_len), parameter :: zero_table_fn = 'pft_sizes.txt' !---------------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------------! + ! Decide whether to write the table with the sizes. ! + !---------------------------------------------------------------------------------------! + print_zero_table = btest(idetailed,5) + !---------------------------------------------------------------------------------------! !---------------------------------------------------------------------------------------! ! The minimum recruitment size and the recruit carbon to nitrogen ratio. Both ! @@ -3090,38 +3164,52 @@ subroutine init_pft_derived_params() !---------------------------------------------------------------------------------------! if (print_zero_table) then open (unit=61,file=trim(zero_table_fn),status='replace',action='write') - write (unit=61,fmt='(18(a,1x))') ' PFT', 'NAME ' & + write (unit=61,fmt='(24(a,1x))') ' PFT', 'NAME ' & ,' HGT_MIN',' DBH' & - ,' BLEAF_MIN',' BDEAD_MIN' & - ,' BALIVE_MIN',' BLEAF_MAX' & - ,' BDEAD_MAX',' BALIVE_MAX' & + ,' BLEAF_MIN',' BROOT_MIN' & + ,'BSAPWOOD_MIN',' BALIVE_MIN' & + ,' BDEAD_MIN',' BLEAF_MAX' & + ,' BROOT_MAX','BSAPWOOD_MAX' & + ,' BALIVE_MAX',' BDEAD_MAX' & ,' INIT_DENS','MIN_REC_SIZE' & ,'MIN_COH_SIZE',' NEGL_NPLANT' & - ,' SLA',' LAI_MIN' & - ,' HGT_MAX',' DBH_CRIT' + ,' SLA','VEG_HCAP_MIN' & + ,' LAI_MIN',' HGT_MAX' & + ,' DBH_CRIT',' ONE_PLANT_C' end if min_plant_dens = onesixth * minval(init_density) do ipft = 1,n_pft !----- Find the DBH and carbon pools associated with a newly formed recruit. --------! - dbh = h2dbh(hgt_min(ipft),ipft) - bleaf_min = dbh2bl(dbh,ipft) - bdead_min = dbh2bd(dbh,ipft) - balive_min = bleaf_min * (1.0 + q(ipft) + qsw(ipft) * hgt_min(ipft)) + dbh = h2dbh(hgt_min(ipft),ipft) + bleaf_min = dbh2bl(dbh,ipft) + broot_min = bleaf_min * q(ipft) + bsapwood_min = bleaf_min * qsw(ipft) * hgt_min(ipft) + balive_min = bleaf_min + broot_min + bsapwood_min + bdead_min = dbh2bd(dbh,ipft) + !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! ! Find the maximum bleaf and bdead supported. This is to find the negligible ! ! nplant so we ensure that the cohort is always terminated if its mortality rate is ! ! very high. ! !------------------------------------------------------------------------------------! - huge_dbh = 3. * dbh_crit(ipft) - huge_height = dbh2h(ipft, dbh_crit(ipft)) - bleaf_max = dbh2bl(huge_dbh,ipft) - bdead_max = dbh2bd(huge_dbh,ipft) - balive_max = bleaf_max * (1.0 + q(ipft) + qsw(ipft) * huge_height) + huge_dbh = 3. * dbh_crit(ipft) + huge_height = dbh2h(ipft, dbh_crit(ipft)) + bleaf_max = dbh2bl(huge_dbh,ipft) + broot_max = bleaf_max * q(ipft) + bsapwood_max = bleaf_max * qsw(ipft) * huge_height + balive_max = bleaf_max + broot_max + bsapwood_max + bdead_max = dbh2bd(huge_dbh,ipft) !------------------------------------------------------------------------------------! + !------------------------------------------------------------------------------------! + ! Biomass of one individual plant at recruitment. ! + !------------------------------------------------------------------------------------! + one_plant_c(ipft) = bdead_min + balive_min + !------------------------------------------------------------------------------------! + !------------------------------------------------------------------------------------! ! The definition of the minimum recruitment size is the minimum amount of biomass ! @@ -3129,7 +3217,7 @@ subroutine init_pft_derived_params() ! ground state value as the minimum recruitment size, but this may change depending ! ! on how well it goes. ! !------------------------------------------------------------------------------------! - min_recruit_size(ipft) = min_plant_dens * (bdead_min + balive_min) + min_recruit_size(ipft) = min_plant_dens * one_plant_c(ipft) !------------------------------------------------------------------------------------! @@ -3163,25 +3251,32 @@ subroutine init_pft_derived_params() !------------------------------------------------------------------------------------! - ! The minimum LAI is the LAI of a plant at the minimum cohort size that is at ! - ! approaching the minimum elongation factor that supports leaves. ! + ! The following variable is the minimum heat capacity of either the leaf, or the ! + ! branches, or the combined pool that is solved by the biophysics. Value is in ! + ! J/m2/K. Because leaves are the pools that can determine the fate of the tree, and ! + ! all PFTs have leaves (but not branches), we only consider the leaf heat capacity ! + ! only for the minimum value. ! !------------------------------------------------------------------------------------! - lai_min(ipft) = 1.e-3 - !lai_min(ipft) = min(1.e-4,min_plant_dens * sla(ipft) * bleaf_min * (5. * elongf_min)) + call calc_veg_hcap(bleaf_min,bdead_min,bsapwood_min,init_density(ipft),ipft & + ,leaf_hcap_min,wood_hcap_min) + veg_hcap_min(ipft) = onesixth * leaf_hcap_min + lai_min = onesixth * init_density(ipft) * bleaf_min * sla(ipft) !------------------------------------------------------------------------------------! if (print_zero_table) then - write (unit=61,fmt='(i5,1x,a16,1x,16(es12.5,1x))') & + write (unit=61,fmt='(i5,1x,a16,1x,22(es12.5,1x))') & ipft,pft_name16(ipft),hgt_min(ipft) & - ,dbh,bleaf_min,bdead_min,balive_min & - ,bleaf_max,bdead_max,balive_max & - ,init_density(ipft) & + ,dbh,bleaf_min,broot_min,bsapwood_min & + ,balive_min,bdead_min,bleaf_max & + ,broot_max,bsapwood_max,balive_max & + ,bdead_max,init_density(ipft) & ,min_recruit_size(ipft) & ,min_cohort_size(ipft) & ,negligible_nplant(ipft) & - ,sla(ipft),lai_min(ipft) & - ,hgt_max(ipft),dbh_crit(ipft) + ,sla(ipft),veg_hcap_min(ipft) & + ,lai_min,hgt_max(ipft),dbh_crit(ipft) & + ,one_plant_c(ipft) end if !------------------------------------------------------------------------------------! end do @@ -3204,8 +3299,7 @@ end subroutine init_pft_derived_params !==========================================================================================! subroutine init_disturb_params - use disturb_coms , only : min_new_patch_area & ! intent(out) - , treefall_hite_threshold & ! intent(out) + use disturb_coms , only : treefall_hite_threshold & ! intent(out) , forestry_on & ! intent(out) , agriculture_on & ! intent(out) , plantation_year & ! intent(out) @@ -3214,7 +3308,6 @@ subroutine init_disturb_params , fire_dryness_threshold & ! intent(out) , fire_smoist_depth & ! intent(out) , k_fire_first & ! intent(out) - , fire_parameter & ! intent(out) , min_plantation_frac & ! intent(out) , max_plantation_dist ! ! intent(out) use consts_coms , only : erad & ! intent(in) @@ -3222,9 +3315,6 @@ subroutine init_disturb_params use soil_coms , only : slz ! ! intent(in) use grid_coms , only : nzg ! ! intent(in) implicit none - - !----- Minimum area that a patch must have to be created. ------------------------------! - min_new_patch_area = 0.005 !----- Only trees above this height create a gap when they fall. -----------------------! treefall_hite_threshold = 10.0 @@ -3255,11 +3345,7 @@ subroutine init_disturb_params fire_smoist_depth = -1.0 !---------------------------------------------------------------------------------------! - !----- Dimensionless parameter controlling speed of fire spread. -----------------------! - fire_parameter = 1.0 - !---------------------------------------------------------------------------------------! - - !----- Determine the top layer to consider for fires in case include_fire is 2. --------! + !----- Determine the top layer to consider for fires in case include_fire is 2 or 3. ---! kfireloop: do k_fire_first=nzg-1,1,-1 if (slz(k_fire_first) < fire_smoist_depth) exit kfireloop end do kfireloop @@ -3325,6 +3411,7 @@ end subroutine init_disturb_params ! ! !------------------------------------------------------------------------------------------! subroutine init_physiology_params() + use detailed_coms , only : idetailed ! ! intent(in) use physiology_coms, only : iphysiol & ! intent(in) , klowco2in & ! intent(in) , c34smin_lint_co2 & ! intent(out) @@ -3621,7 +3708,7 @@ subroutine init_physiology_params() ! Parameters that control debugging output. ! !---------------------------------------------------------------------------------------! !----- I should print detailed debug information. --------------------------------------! - print_photo_debug = .false. + print_photo_debug = btest(idetailed,1) !----- File name prefix for the detailed information in case of debugging. -------------! photo_prefix = 'photo_state_' !---------------------------------------------------------------------------------------! @@ -3735,8 +3822,8 @@ subroutine init_soil_coms !----- Initialise some standard variables. ---------------------------------------------! - water_stab_thresh = 3.0 ! Minimum water mass to be considered stable [ kg/m2] - snowmin = 3.0 ! Minimum snow mass needed to create a new layer [ kg/m2] + water_stab_thresh = 5.0 ! Minimum water mass to be considered stable [ kg/m2] + snowmin = 5.0 ! Minimum snow mass needed to create a new layer [ kg/m2] dewmax = 3.0e-5 ! Maximum dew flux rate (deprecated) [ kg/m2/s] soil_rough = 0.05 ! Soil roughness height [ m] snow_rough = 0.001 ! Snowcover roughness height [ m] @@ -3762,7 +3849,7 @@ subroutine init_soil_coms ! (2nd line) soilwp slcons slcons0 soilcond0 soilcond1 ! ! (3rd line) soilcond2 sfldcap albwet albdry xsand ! ! (4th line) xclay xsilt xrobulk slden soilld ! - ! (5th line) soilfr slpotwp slpotfc slpotld ! + ! (5th line) soilfr slpotwp slpotfc slpotld slpotfr ! !---------------------------------------------------------------------------------------! soil = (/ & !----- 1. Sand. ---------------------------------------------------------------------! @@ -3770,103 +3857,103 @@ subroutine init_soil_coms , 0.032636854, 2.446421e-5, 0.000500000, 0.3000, 4.8000 & , -2.7000, 0.132130936, 0.229, 0.352, 0.920 & , 0.030, 0.050, 1200., 1600., 0.000 & - , 0.000, 0.000, 0.000, 0.000 ) & + , 0.000, 0.000, 0.000, 0.000, 0.000) & !----- 2. Loamy sand. ---------------------------------------------------------------! ,soil_class( -0.067406224, 0.385630, 3.794500, 1584809., 0.041560499 & , 0.050323046, 1.776770e-5, 0.000600000, 0.3000, 4.6600 & , -2.6000, 0.155181959, 0.212, 0.335, 0.825 & , 0.060, 0.115, 1250., 1600., 0.000 & - , 0.000, 0.000, 0.000, 0.000 ) & + , 0.000, 0.000, 0.000, 0.000, 0.000) & !----- 3. Sandy loam. ---------------------------------------------------------------! ,soil_class( -0.114261521, 0.407210, 4.629000, 1587042., 0.073495043 & , 0.085973722, 1.022660e-5, 0.000769000, 0.2900, 4.2700 & , -2.3100, 0.194037750, 0.183, 0.307, 0.660 & , 0.110, 0.230, 1300., 1600., 0.000 & - , 0.000, 0.000, 0.000, 0.000 ) & + , 0.000, 0.000, 0.000, 0.000, 0.000) & !----- 4. Silt loam. ----------------------------------------------------------------! ,soil_class( -0.566500112, 0.470680, 5.552000, 1568225., 0.150665475 & , 0.171711257, 2.501101e-6, 0.000010600, 0.2700, 3.4700 & , -1.7400, 0.273082063, 0.107, 0.250, 0.200 & , 0.160, 0.640, 1400., 1600., 0.000 & - , 0.000, 0.000, 0.000, 0.000 ) & + , 0.000, 0.000, 0.000, 0.000, 0.000) & !----- 5. Loam. ---------------------------------------------------------------------! ,soil_class( -0.260075834, 0.440490, 5.646000, 1588082., 0.125192234 & , 0.142369513, 4.532431e-6, 0.002200000, 0.2800, 3.6300 & , -1.8500, 0.246915025, 0.140, 0.268, 0.410 & , 0.170, 0.420, 1350., 1600., 0.000 & - , 0.000, 0.000, 0.000, 0.000 ) & + , 0.000, 0.000, 0.000, 0.000, 0.000) & !----- 6. Sandy clay loam. ----------------------------------------------------------! ,soil_class( -0.116869181, 0.411230, 7.162000, 1636224., 0.136417267 & , 0.150969505, 6.593731e-6, 0.001500000, 0.2800, 3.7800 & , -1.9600, 0.249629687, 0.163, 0.260, 0.590 & , 0.270, 0.140, 1350., 1600., 0.000 & - , 0.000, 0.000, 0.000, 0.000 ) & + , 0.000, 0.000, 0.000, 0.000, 0.000) & !----- 7. Silty clay loam. ----------------------------------------------------------! ,soil_class( -0.627769194, 0.478220, 8.408000, 1621562., 0.228171947 & , 0.248747504, 1.435262e-6, 0.000107000, 0.2600, 2.7300 & , -1.2000, 0.333825332, 0.081, 0.195, 0.100 & , 0.340, 0.560, 1500., 1600., 0.000 & - , 0.000, 0.000, 0.000, 0.000 ) & + , 0.000, 0.000, 0.000, 0.000, 0.000) & !----- 8. Clayey loam. --------------------------------------------------------------! ,soil_class( -0.281968114, 0.446980, 8.342000, 1636911., 0.192624431 & , 0.210137962, 2.717260e-6, 0.002200000, 0.2700, 3.2300 & , -1.5600, 0.301335491, 0.116, 0.216, 0.320 & , 0.340, 0.340, 1450., 1600., 0.000 & - , 0.000, 0.000, 0.000, 0.000 ) & + , 0.000, 0.000, 0.000, 0.000, 0.000) & !----- 9. Sandy clay. ---------------------------------------------------------------! ,soil_class( -0.121283019, 0.415620, 9.538000, 1673422., 0.182198910 & , 0.196607427, 4.314507e-6, 0.000002167, 0.2700, 3.3200 & , -1.6300, 0.286363001, 0.144, 0.216, 0.520 & , 0.420, 0.060, 1450., 1600., 0.000 & - , 0.000, 0.000, 0.000, 0.000 ) & + , 0.000, 0.000, 0.000, 0.000, 0.000) & !----- 10. Silty clay. --------------------------------------------------------------! ,soil_class( -0.601312179, 0.479090, 10.461000, 1652723., 0.263228486 & , 0.282143846, 1.055191e-6, 0.000001033, 0.2500, 2.5800 & , -1.0900, 0.360319788, 0.068, 0.159, 0.060 & , 0.470, 0.470, 1650., 1600., 0.000 & - , 0.000, 0.000, 0.000, 0.000 ) & + , 0.000, 0.000, 0.000, 0.000, 0.000) & !----- 11. Clay. --------------------------------------------------------------------! ,soil_class( -0.299226464, 0.454400, 12.460000, 1692037., 0.259868987 & , 0.275459057, 1.307770e-6, 0.000001283, 0.2500, 2.4000 & , -0.9600, 0.353255209, 0.083, 0.140, 0.200 & , 0.600, 0.200, 1700., 1600., 0.000 & - , 0.000, 0.000, 0.000, 0.000 ) & + , 0.000, 0.000, 0.000, 0.000, 0.000) & !----- 12. Peat. --------------------------------------------------------------------! ,soil_class( -0.534564359, 0.469200, 6.180000, 874000., 0.167047523 & , 0.187868805, 2.357930e-6, 0.000008000, 0.0600, 0.4600 & , 0.0000, 0.285709966, 0.070, 0.140, 0.2000 & , 0.2000, 0.6000, 500., 300., 0.000 & - , 0.000, 0.000, 0.000, 0.000 ) & + , 0.000, 0.000, 0.000, 0.000, 0.000) & !----- 13. Bedrock. -----------------------------------------------------------------! ,soil_class( 0.0000000, 0.000000, 0.000000, 2130000., 0.000000000 & , 0.000000000, 0.000000e+0, 0.000000000, 4.6000, 0.0000 & , 0.0000, 0.000000001, 0.320, 0.320, 0.0000 & , 0.0000, 0.0000, 0., 0., 0.000 & - , 0.000, 0.000, 0.000, 0.000 ) & + , 0.000, 0.000, 0.000, 0.000, 0.000) & !----- 14. Silt. --------------------------------------------------------------------! ,soil_class( -1.047128548, 0.492500, 3.862500, 1510052., 0.112299080 & , 0.135518820, 2.046592e-6, 0.000010600, 0.2700, 3.4700 & , -1.7400, 0.245247642, 0.092, 0.265, 0.075 & , 0.050, 0.875, 1400., 1600., 0.000 & - , 0.000, 0.000, 0.000, 0.000 ) & + , 0.000, 0.000, 0.000, 0.000, 0.000) & !----- 15. Heavy clay. --------------------------------------------------------------! ,soil_class( -0.322106879, 0.461200, 15.630000, 1723619., 0.296806035 & , 0.310916364, 7.286705e-7, 0.000001283, 0.2500, 2.4000 & , -0.9600, 0.382110712, 0.056, 0.080, 0.100 & , 0.800, 0.100, 1700., 1600., 0.000 & - , 0.000, 0.000, 0.000, 0.000 ) & + , 0.000, 0.000, 0.000, 0.000, 0.000) & !----- 16. Clayey sand. -------------------------------------------------------------! ,soil_class( -0.176502150, 0.432325, 11.230000, 1688353., 0.221886929 & , 0.236704039, 2.426785e-6, 0.000001283, 0.2500, 2.4000 & , -0.9600, 0.320146708, 0.115, 0.175, 0.375 & , 0.525, 0.100, 1700., 1600., 0.000 & - , 0.000, 0.000, 0.000, 0.000 ) & + , 0.000, 0.000, 0.000, 0.000, 0.000) & !----- 17. Clayey silt. -------------------------------------------------------------! ,soil_class( -0.438278332, 0.467825, 11.305000, 1670103., 0.261376708 & , 0.278711303, 1.174982e-6, 0.000001283, 0.2500, 2.4000 & , -0.9600, 0.357014719, 0.075, 0.151, 0.125 & , 0.525, 0.350, 1700., 1600., 0.000 & - , 0.000, 0.000, 0.000, 0.000 ) & + , 0.000, 0.000, 0.000, 0.000, 0.000) & /) !---------------------------------------------------------------------------------------! @@ -3992,6 +4079,7 @@ subroutine init_soil_coms soil(nsoil)%soilfr = 0.0 soil(nsoil)%slpotwp = 0.0 soil(nsoil)%slpotfc = 0.0 + soil(nsoil)%slpotfr = 0.0 case default !---------------------------------------------------------------------------------! ! Critical point for leaf drop. ! @@ -4033,6 +4121,9 @@ subroutine init_soil_coms soil(nsoil)%slpotwp = soil(nsoil)%slpots & / (soil(nsoil)%soilwp / soil(nsoil)%slmsts) & ** soil(nsoil)%slbs + soil(nsoil)%slpotfr = soil(nsoil)%slpots & + / (soil(nsoil)%soilfr / soil(nsoil)%slmsts) & + ** soil(nsoil)%slbs soil(nsoil)%slpotfc = soil(nsoil)%slpots & / (soil(nsoil)%sfldcap / soil(nsoil)%slmsts) & ** soil(nsoil)%slbs @@ -4108,6 +4199,7 @@ subroutine init_soil_coms soil8(nsoil)%slpotwp = dble(soil(nsoil)%slpotwp ) soil8(nsoil)%slpotfc = dble(soil(nsoil)%slpotfc ) soil8(nsoil)%slpotld = dble(soil(nsoil)%slpotld ) + soil8(nsoil)%slpotfr = dble(soil(nsoil)%slpotfr ) end do soil_rough8 = dble(soil_rough) snow_rough8 = dble(snow_rough) @@ -4360,6 +4452,7 @@ subroutine init_rk4_params() use met_driver_coms, only : prss_min & ! intent(in) , prss_max ! ! intent(in) use consts_coms , only : wdnsi8 ! ! intent(in) + use detailed_coms , only : idetailed ! ! intent(in) use rk4_coms , only : rk4_tolerance & ! intent(in) , ibranch_thermo & ! intent(in) , maxstp & ! intent(out) @@ -4384,8 +4477,6 @@ subroutine init_rk4_params() , rk4max_can_temp & ! intent(out) , rk4min_can_shv & ! intent(out) , rk4max_can_shv & ! intent(out) - , rk4min_can_rvap & ! intent(out) - , rk4max_can_rvap & ! intent(out) , rk4min_can_rhv & ! intent(out) , rk4max_can_rhv & ! intent(out) , rk4min_can_co2 & ! intent(out) @@ -4403,15 +4494,16 @@ subroutine init_rk4_params() , effarea_evap & ! intent(out) , effarea_transp & ! intent(out) , leaf_intercept & ! intent(out) - , force_idealgas & ! intent(out) , supersat_ok & ! intent(out) , record_err & ! intent(out) , print_detailed & ! intent(out) + , print_budget & ! intent(out) , print_thbnd & ! intent(out) , errmax_fout & ! intent(out) , sanity_fout & ! intent(out) , thbnds_fout & ! intent(out) - , detail_pref ! ! intent(out) + , detail_pref & ! intent(out) + , budget_pref ! ! intent(out) implicit none !---------------------------------------------------------------------------------------! @@ -4435,7 +4527,7 @@ subroutine init_rk4_params() rk4eps2 = rk4eps**2 ! square of the accuracy hmin = 1.d-7 ! The minimum step size. print_diags = .false. ! Flag to print the diagnostic check. - checkbudget = .true. ! Flag to check CO2, water, and energy budgets every + checkbudget = .false. ! Flag to check CO2, water, and energy budgets every ! time step and stop the run in case any of these ! budgets don't close. !---------------------------------------------------------------------------------------! @@ -4455,18 +4547,24 @@ subroutine init_rk4_params() !---------------------------------------------------------------------------------------! - ! Variables used to keep track on the error. ! + ! Variables used to keep track on the error. We use the idetailed flag to ! + ! determine whether to create the output value or not. ! + !---------------------------------------------------------------------------------------! + !------ Detailed budget (every DTLSM). -------------------------------------------------! + print_budget = btest(idetailed,0) + if (print_budget) checkbudget = .true. + !------ Detailed output from the integrator (every HDID). ------------------------------! + print_detailed = btest(idetailed,2) + !------ Thermodynamic boundaries for sanity check (every HDID). ------------------------! + print_thbnd = btest(idetailed,3) + !------ Daily error statistics (count how often a variable shrunk the time step). ------! + record_err = btest(idetailed,4) !---------------------------------------------------------------------------------------! - record_err = .false. ! Compute and keep track of the errors. - print_detailed = .false. ! Print detailed information about the thermo- - ! dynamic state. This will create one file - ! for each patch, so it is not recommended - ! for simulations that span over one month. - print_thbnd = .false. ! Make a file with thermodynamic boundaries. errmax_fout = 'error_max_count.txt' ! File with the maximum error count sanity_fout = 'sanity_check_count.txt' ! File with the sanity check count thbnds_fout = 'thermo_bounds.txt' ! File with the thermodynamic boundaries. detail_pref = 'thermo_state_' ! Prefix for the detailed thermodynamic file + budget_pref = 'budget_state_' ! File with the thermodynamic boundaries. !---------------------------------------------------------------------------------------! @@ -4478,7 +4576,7 @@ subroutine init_rk4_params() rk4min_can_temp = 1.8400d2 ! Minimum canopy temperature [ K] rk4max_can_temp = 3.5100d2 ! Maximum canopy temperature [ K] rk4min_can_shv = 1.0000d-8 ! Minimum canopy specific humidity [kg/kg_air] - rk4max_can_shv = 8.0000d-2 ! Maximum canopy specific humidity [kg/kg_air] + rk4max_can_shv = 6.0000d-2 ! Maximum canopy specific humidity [kg/kg_air] rk4max_can_rhv = 1.1000d0 ! Maximum canopy relative humidity (**) [ ---] rk4min_can_co2 = 3.0000d1 ! Minimum canopy CO2 mixing ratio [ µmol/mol] rk4max_can_co2 = 5.0000d4 ! Maximum canopy CO2 mixing ratio [ µmol/mol] @@ -4495,14 +4593,6 @@ subroutine init_rk4_params() !---------------------------------------------------------------------------------------! - !---------------------------------------------------------------------------------------! - ! Compute the minimum and maximum mixing ratio based on the specific humidity. ! - !---------------------------------------------------------------------------------------! - rk4min_can_rvap = rk4min_can_shv / (1.d0 - rk4min_can_shv) - rk4max_can_rvap = rk4max_can_shv / (1.d0 - rk4max_can_shv) - !---------------------------------------------------------------------------------------! - - !---------------------------------------------------------------------------------------! ! Minimum water mass at the leaf surface. This is given in kg/m²leaf rather than ! ! kg/m²ground, so we scale it with LAI. ! @@ -4558,16 +4648,6 @@ subroutine init_rk4_params() !---------------------------------------------------------------------------------------! - !---------------------------------------------------------------------------------------! - ! The integrator will adjust pressure every time step, including the internal ones, ! - ! to make sure the ideal gas is respected. If set to false, it will keep pressure ! - ! constant within on DTLSM time step, and not bother forcing the canopy air space to ! - ! respect the ideal gas equation. ! - !---------------------------------------------------------------------------------------! - force_idealgas = .false. - !---------------------------------------------------------------------------------------! - - !---------------------------------------------------------------------------------------! ! This flag is to turn on and on the leaf interception. Except for developer ! diff --git a/ED/src/init/ed_type_init.f90 b/ED/src/init/ed_type_init.f90 index c12d9e36f..653e131a4 100644 --- a/ED/src/init/ed_type_init.f90 +++ b/ED/src/init/ed_type_init.f90 @@ -59,9 +59,6 @@ subroutine init_ed_cohort_vars(cpatch,ico, lsl) cpatch%light_level (ico) = 0.0 cpatch%light_level_beam(ico) = 0.0 cpatch%light_level_diff(ico) = 0.0 - cpatch%beamext_level (ico) = 0.0 - cpatch%diffext_level (ico) = 0.0 - cpatch%lambda_light(ico) = 0.0 cpatch%gpp(ico) = 0.0 cpatch%leaf_respiration(ico) = 0.0 @@ -141,31 +138,6 @@ subroutine init_ed_cohort_vars(cpatch,ico, lsl) !---------------------------------------------------------------------------------------! - !---------------------------------------------------------------------------------------! - ! The stomate structure. This is initialised with zeroes except for the "recalc" ! - ! element, which should be set to 1 so the photosynthesis will be solved exactly at the ! - ! first time. ! - !---------------------------------------------------------------------------------------! - cpatch%old_stoma_data(ico)%recalc = 1 - cpatch%old_stoma_data(ico)%T_L = 0.0 - cpatch%old_stoma_data(ico)%e_A = 0.0 - cpatch%old_stoma_data(ico)%PAR = 0.0 - cpatch%old_stoma_data(ico)%rb_factor = 0.0 - cpatch%old_stoma_data(ico)%prss = 0.0 - cpatch%old_stoma_data(ico)%phenology_factor = 0.0 - cpatch%old_stoma_data(ico)%gsw_open = 0.0 - cpatch%old_stoma_data(ico)%ilimit = 0 - cpatch%old_stoma_data(ico)%T_L_residual = 0.0 - cpatch%old_stoma_data(ico)%e_a_residual = 0.0 - cpatch%old_stoma_data(ico)%par_residual = 0.0 - cpatch%old_stoma_data(ico)%rb_residual = 0.0 - cpatch%old_stoma_data(ico)%leaf_residual = 0.0 - cpatch%old_stoma_data(ico)%gsw_residual = 0.0 - cpatch%old_stoma_vector(:,ico) = 0. - cpatch%old_stoma_vector(1,ico) = 1. - !---------------------------------------------------------------------------------------! - - !---------------------------------------------------------------------------------------! @@ -190,11 +162,13 @@ subroutine init_ed_cohort_vars(cpatch,ico, lsl) cpatch%leaf_energy(ico) = 0. cpatch%leaf_hcap(ico) = 0. cpatch%leaf_temp(ico) = 0. + cpatch%leaf_temp_pv(ico) = 0. cpatch%leaf_water(ico) = 0. cpatch%leaf_fliq(ico) = 0. cpatch%wood_energy(ico) = 0. cpatch%wood_hcap(ico) = 0. cpatch%wood_temp(ico) = 0. + cpatch%wood_temp_pv(ico) = 0. cpatch%wood_water(ico) = 0. cpatch%wood_fliq(ico) = 0. cpatch%veg_wind(ico) = 0. @@ -239,15 +213,12 @@ subroutine init_ed_cohort_vars(cpatch,ico, lsl) cpatch%mmean_light_level (ico) = 0.0 cpatch%mmean_light_level_beam (ico) = 0.0 cpatch%mmean_light_level_diff (ico) = 0.0 - cpatch%mmean_beamext_level (ico) = 0.0 - cpatch%mmean_diffext_level (ico) = 0.0 cpatch%mmean_fs_open (ico) = 0.0 cpatch%mmean_fsw (ico) = 0.0 cpatch%mmean_fsn (ico) = 0.0 cpatch%mmean_psi_open (ico) = 0.0 cpatch%mmean_psi_closed (ico) = 0.0 cpatch%mmean_water_supply (ico) = 0.0 - cpatch%mmean_lambda_light (ico) = 0.0 cpatch%mmean_leaf_maintenance (ico) = 0.0 cpatch%mmean_root_maintenance (ico) = 0.0 cpatch%mmean_leaf_drop (ico) = 0.0 @@ -279,15 +250,12 @@ subroutine init_ed_cohort_vars(cpatch,ico, lsl) cpatch%dmean_light_level (ico) = 0.0 cpatch%dmean_light_level_beam (ico) = 0.0 cpatch%dmean_light_level_diff (ico) = 0.0 - cpatch%dmean_beamext_level (ico) = 0.0 - cpatch%dmean_diffext_level (ico) = 0.0 cpatch%dmean_fsw (ico) = 0.0 cpatch%dmean_fsn (ico) = 0.0 cpatch%dmean_fs_open (ico) = 0.0 cpatch%dmean_psi_open (ico) = 0.0 cpatch%dmean_psi_closed (ico) = 0.0 cpatch%dmean_water_supply (ico) = 0.0 - cpatch%dmean_lambda_light (ico) = 0.0 end if @@ -385,15 +353,6 @@ subroutine init_ed_patch_vars(csite,ip1,ip2,lsl) !---------------------------------------------------------------------------------------! - - do ipa = ip1,ip2 - !------ Make sure photosynthesis will be calculated at the first time. --------------! - do ipft = 1,n_pft - csite%old_stoma_data_max(ipft,ipa)%recalc = 1 - end do - end do - - !------ Initialise soil state variables. -----------------------------------------------! csite%soil_water(1:nzg,ip1:ip2) = 0.0 csite%soil_energy(1:nzg,ip1:ip2) = 0.0 @@ -429,7 +388,6 @@ subroutine init_ed_patch_vars(csite,ip1,ip2,lsl) csite%f_decomp(ip1:ip2) = 0.0 csite%rh(ip1:ip2) = 0.0 csite%cwd_rh(ip1:ip2) = 0.0 - csite%fuse_flag(ip1:ip2) = 0.0 csite%plant_ag_biomass(ip1:ip2) = 0.0 csite%mean_runoff(ip1:ip2) = 0.0 @@ -449,32 +407,33 @@ subroutine init_ed_patch_vars(csite,ip1,ip2,lsl) csite%A_o_max(1:n_pft,ip1:ip2) = 0.0 csite%A_c_max(1:n_pft,ip1:ip2) = 0.0 - csite%htry(ip1:ip2) = 1.0 - - - csite%co2budget_gpp(ip1:ip2) = 0.0 - csite%co2budget_gpp_dbh(:,ip1:ip2) = 0.0 - csite%co2budget_rh(ip1:ip2) = 0.0 - csite%co2budget_plresp(ip1:ip2) = 0.0 - csite%co2budget_initialstorage(ip1:ip2) = 0.0 - csite%co2budget_loss2atm(ip1:ip2) = 0.0 - csite%co2budget_denseffect(ip1:ip2) = 0.0 - csite%co2budget_residual(ip1:ip2) = 0.0 - csite%wbudget_precipgain(ip1:ip2) = 0.0 - csite%wbudget_loss2atm(ip1:ip2) = 0.0 - csite%wbudget_loss2runoff(ip1:ip2) = 0.0 - csite%wbudget_loss2drainage(ip1:ip2) = 0.0 - csite%wbudget_denseffect(ip1:ip2) = 0.0 - csite%wbudget_initialstorage(ip1:ip2) = 0.0 - csite%wbudget_residual(ip1:ip2) = 0.0 - csite%ebudget_precipgain(ip1:ip2) = 0.0 - csite%ebudget_netrad(ip1:ip2) = 0.0 - csite%ebudget_loss2atm(ip1:ip2) = 0.0 - csite%ebudget_loss2runoff(ip1:ip2) = 0.0 - csite%ebudget_loss2drainage(ip1:ip2) = 0.0 - csite%ebudget_denseffect(ip1:ip2) = 0.0 - csite%ebudget_initialstorage(ip1:ip2) = 0.0 - csite%ebudget_residual(ip1:ip2) = 0.0 + csite%htry(ip1:ip2) = 1.0 + csite%hprev(ip1:ip2) = 0.1 + + csite%co2budget_gpp (ip1:ip2) = 0.0 + csite%co2budget_gpp_dbh (:,ip1:ip2) = 0.0 + csite%co2budget_rh (ip1:ip2) = 0.0 + csite%co2budget_plresp (ip1:ip2) = 0.0 + csite%co2budget_initialstorage (ip1:ip2) = 0.0 + csite%co2budget_loss2atm (ip1:ip2) = 0.0 + csite%co2budget_denseffect (ip1:ip2) = 0.0 + csite%co2budget_residual (ip1:ip2) = 0.0 + csite%wbudget_precipgain (ip1:ip2) = 0.0 + csite%wbudget_loss2atm (ip1:ip2) = 0.0 + csite%wbudget_loss2runoff (ip1:ip2) = 0.0 + csite%wbudget_loss2drainage (ip1:ip2) = 0.0 + csite%wbudget_denseffect (ip1:ip2) = 0.0 + csite%wbudget_initialstorage (ip1:ip2) = 0.0 + csite%wbudget_residual (ip1:ip2) = 0.0 + csite%ebudget_precipgain (ip1:ip2) = 0.0 + csite%ebudget_netrad (ip1:ip2) = 0.0 + csite%ebudget_loss2atm (ip1:ip2) = 0.0 + csite%ebudget_loss2runoff (ip1:ip2) = 0.0 + csite%ebudget_loss2drainage (ip1:ip2) = 0.0 + csite%ebudget_denseffect (ip1:ip2) = 0.0 + csite%ebudget_prsseffect (ip1:ip2) = 0.0 + csite%ebudget_initialstorage (ip1:ip2) = 0.0 + csite%ebudget_residual (ip1:ip2) = 0.0 @@ -485,7 +444,6 @@ subroutine init_ed_patch_vars(csite,ip1,ip2,lsl) csite%dmean_co2_residual (ip1:ip2) = 0.0 csite%dmean_energy_residual (ip1:ip2) = 0.0 csite%dmean_water_residual (ip1:ip2) = 0.0 - csite%dmean_lambda_light (ip1:ip2) = 0.0 csite%dmean_rk4step (ip1:ip2) = 0.0 csite%dmean_albedo (ip1:ip2) = 0.0 csite%dmean_albedo_beam (ip1:ip2) = 0.0 @@ -499,7 +457,6 @@ subroutine init_ed_patch_vars(csite,ip1,ip2,lsl) csite%mmean_co2_residual (ip1:ip2) = 0.0 csite%mmean_energy_residual (ip1:ip2) = 0.0 csite%mmean_water_residual (ip1:ip2) = 0.0 - csite%mmean_lambda_light (ip1:ip2) = 0.0 csite%mmean_rk4step (ip1:ip2) = 0.0 csite%mmean_albedo (ip1:ip2) = 0.0 csite%mmean_albedo_beam (ip1:ip2) = 0.0 @@ -543,7 +500,6 @@ subroutine init_ed_patch_vars(csite,ip1,ip2,lsl) csite%avg_runoff (ip1:ip2) = 0.0 csite%avg_drainage (ip1:ip2) = 0.0 csite%avg_drainage_heat (ip1:ip2) = 0.0 - csite%aux (ip1:ip2) = 0.0 csite%avg_sensible_lc (ip1:ip2) = 0.0 csite%avg_sensible_wc (ip1:ip2) = 0.0 csite%avg_qwshed_vg (ip1:ip2) = 0.0 @@ -555,7 +511,6 @@ subroutine init_ed_patch_vars(csite,ip1,ip2,lsl) csite%avg_sensible_gg (:,ip1:ip2) = 0.0 csite%avg_smoist_gg (:,ip1:ip2) = 0.0 csite%avg_transloss (:,ip1:ip2) = 0.0 - csite%aux_s (:,ip1:ip2) = 0.0 csite%avg_available_water (ip1:ip2) = 0.0 csite%avg_leaf_energy (ip1:ip2) = 0.0 csite%avg_leaf_temp (ip1:ip2) = 0.0 @@ -588,7 +543,6 @@ subroutine init_ed_patch_vars(csite,ip1,ip2,lsl) csite%albedo_diffuse (ip1:ip2) = 0.0 csite%rlongup (ip1:ip2) = 0.0 csite%rlong_albedo (ip1:ip2) = 0.0 - csite%lambda_light (ip1:ip2) = 0.0 csite%fsc_in (ip1:ip2) = 0.0 csite%ssc_in (ip1:ip2) = 0.0 @@ -613,6 +567,7 @@ subroutine init_ed_patch_vars(csite,ip1,ip2,lsl) csite%can_theiv (ip1:ip2) = 0.0 csite%can_temp (ip1:ip2) = 0.0 + csite%can_temp_pv (ip1:ip2) = 0.0 csite%can_rhos (ip1:ip2) = 0.0 csite%can_depth (ip1:ip2) = 0.0 csite%opencan_frac(ip1:ip2) = 0.0 @@ -626,28 +581,6 @@ subroutine init_ed_patch_vars(csite,ip1,ip2,lsl) csite%ggnet (ip1:ip2) = 0.0 csite%ggsoil(ip1:ip2) = 0.0 - csite%old_stoma_data_max(:,ip1:ip2)%recalc = 1 - csite%old_stoma_data_max(:,ip1:ip2)%T_L = 0.0 - csite%old_stoma_data_max(:,ip1:ip2)%e_A = 0.0 - csite%old_stoma_data_max(:,ip1:ip2)%PAR = 0.0 - csite%old_stoma_data_max(:,ip1:ip2)%rb_factor = 0.0 - csite%old_stoma_data_max(:,ip1:ip2)%prss = 0.0 - csite%old_stoma_data_max(:,ip1:ip2)%phenology_factor = 0.0 - csite%old_stoma_data_max(:,ip1:ip2)%gsw_open = 0.0 - csite%old_stoma_data_max(:,ip1:ip2)%ilimit = 0 - csite%old_stoma_data_max(:,ip1:ip2)%T_L_residual = 0.0 - csite%old_stoma_data_max(:,ip1:ip2)%e_a_residual = 0.0 - csite%old_stoma_data_max(:,ip1:ip2)%par_residual = 0.0 - csite%old_stoma_data_max(:,ip1:ip2)%rb_residual = 0.0 - csite%old_stoma_data_max(:,ip1:ip2)%leaf_residual = 0.0 - csite%old_stoma_data_max(:,ip1:ip2)%gsw_residual = 0.0 - - - csite%old_stoma_vector_max(:,:,ip1:ip2) = 0. - csite%old_stoma_vector_max(1,:,ip1:ip2) = & - real(csite%old_stoma_data_max(:,ip1:ip2)%recalc) - - ncohorts = 0 do ipa=1,csite%npatches ncohorts = ncohorts + csite%patch(ipa)%ncohorts @@ -842,8 +775,8 @@ subroutine new_patch_sfc_props(csite,ipa,mzg,mzs,ntext_soil) , slz & ! intent(in) , tiny_sfcwater_mass ! ! intent(in) use consts_coms , only : wdns ! ! intent(in) - use therm_lib , only : qwtk & ! subroutine - , qtk ! ! subroutine + use therm_lib , only : uextcm2tl & ! subroutine + , uint2tl ! ! subroutine use ed_therm_lib , only : ed_grndvap ! ! subroutine implicit none !----- Arguments -----------------------------------------------------------------------! @@ -862,8 +795,8 @@ subroutine new_patch_sfc_props(csite,ipa,mzg,mzs,ntext_soil) !----- Finding soil temperature and liquid water fraction. -----------------------------! do k = 1, mzg nsoil = ntext_soil(k) - call qwtk(csite%soil_energy(k,ipa), csite%soil_water(k,ipa)*wdns & - ,soil(nsoil)%slcpd, csite%soil_tempk(k,ipa), csite%soil_fracliq(k,ipa)) + call uextcm2tl(csite%soil_energy(k,ipa), csite%soil_water(k,ipa)*wdns & + ,soil(nsoil)%slcpd, csite%soil_tempk(k,ipa), csite%soil_fracliq(k,ipa)) end do !---------------------------------------------------------------------------------------! @@ -881,8 +814,8 @@ subroutine new_patch_sfc_props(csite,ipa,mzg,mzs,ntext_soil) csite%nlev_sfcwater(ipa) = k csite%sfcwater_energy(k,ipa) = csite%sfcwater_energy(k,ipa) & / csite%sfcwater_mass(k,ipa) - call qtk(csite%sfcwater_energy(k,ipa),csite%sfcwater_tempk(k,ipa) & - ,csite%sfcwater_fracliq(k,ipa)) + call uint2tl(csite%sfcwater_energy(k,ipa),csite%sfcwater_tempk(k,ipa) & + ,csite%sfcwater_fracliq(k,ipa)) end do snowloop !---------------------------------------------------------------------------------------! ! Now, just to be safe, we will assign zeroes to layers above. ! diff --git a/ED/src/init/phenology_startup.f90 b/ED/src/init/phenology_startup.f90 index b5473014a..fdc921a22 100644 --- a/ED/src/init/phenology_startup.f90 +++ b/ED/src/init/phenology_startup.f90 @@ -331,7 +331,11 @@ subroutine read_thermal_sums end do end do - deallocate(flat,flon,varc,varp) + deallocate(flat ) + deallocate(flon ) + deallocate(fdist) + deallocate(varc ) + deallocate(varp ) return end subroutine read_thermal_sums @@ -420,20 +424,20 @@ end subroutine fill_thermal_sums !---------------------------------------------------------------------------------------! subroutine read_prescribed_phenology - use ed_state_vars , only : edgrid_g & ! structure - , edtype & ! structure - , polygontype & ! structure - , sitetype ! ! structure - use ed_misc_coms , only : imontha & ! intent(in) - , idatea & ! intent(in) - , iyeara ! ! intent(in) - use grid_coms , only : ngrids ! ! intent(in) - use phenology_coms, only : prescribed_phen & ! structure - , phenpath & ! intent(in) - , max_phenology_dist ! ! intent(in) - use ed_max_dims , only : str_len & ! intent(in) - , maxlist ! ! intent(in) - + use ed_state_vars , only : edgrid_g & ! structure + , edtype & ! structure + , polygontype & ! structure + , sitetype ! ! structure + use ed_misc_coms , only : imontha & ! intent(in) + , idatea & ! intent(in) + , iyeara ! ! intent(in) + use grid_coms , only : ngrids ! ! intent(in) + use phenology_coms, only : prescribed_phen & ! structure + , phenpath & ! intent(in) + , max_phenology_dist ! ! intent(in) + use ed_max_dims , only : str_len & ! intent(in) + , maxlist ! ! intent(in) + use phenology_aux , only : prescribed_leaf_state ! ! subroutine implicit none !----- Local variables. -------------------------------------------------------------! type(edtype) , pointer :: cgrid diff --git a/ED/src/io/average_utils.f90 b/ED/src/io/average_utils.f90 index 06557e58b..ff905ca9c 100644 --- a/ED/src/io/average_utils.f90 +++ b/ED/src/io/average_utils.f90 @@ -193,7 +193,6 @@ subroutine normalize_averaged_vars(cgrid,frqsum,dtlsm) csite%avg_albedo_beam (ipa) = csite%avg_albedo_beam (ipa) * frqsumi csite%avg_albedo_diffuse (ipa) = csite%avg_albedo_diffuse (ipa) * frqsumi csite%avg_rlong_albedo (ipa) = csite%avg_rlong_albedo (ipa) * frqsumi - csite%aux (ipa) = csite%aux (ipa) * frqsumi csite%avg_vapor_lc (ipa) = csite%avg_vapor_lc (ipa) * frqsumi csite%avg_vapor_wc (ipa) = csite%avg_vapor_wc (ipa) * frqsumi csite%avg_vapor_gc (ipa) = csite%avg_vapor_gc (ipa) * frqsumi @@ -228,7 +227,6 @@ subroutine normalize_averaged_vars(cgrid,frqsum,dtlsm) csite%avg_sensible_gg(k,ipa) = csite%avg_sensible_gg(k,ipa) * frqsumi csite%avg_smoist_gg(k,ipa) = csite%avg_smoist_gg(k,ipa) * frqsumi csite%avg_transloss(k,ipa) = csite%avg_transloss(k,ipa) * frqsumi - csite%aux_s(k,ipa) = csite%aux_s(k,ipa) * frqsumi end do !------------------------------------------------------------------------------! @@ -272,6 +270,7 @@ subroutine normalize_averaged_vars(cgrid,frqsum,dtlsm) csite%ebudget_precipgain(ipa) = csite%ebudget_precipgain(ipa) * frqsumi csite%ebudget_netrad(ipa) = csite%ebudget_netrad(ipa) * frqsumi csite%ebudget_denseffect(ipa) = csite%ebudget_denseffect(ipa) * frqsumi + csite%ebudget_prsseffect(ipa) = csite%ebudget_prsseffect(ipa) * frqsumi csite%ebudget_loss2atm(ipa) = csite%ebudget_loss2atm(ipa) * frqsumi csite%ebudget_loss2drainage(ipa) = csite%ebudget_loss2drainage(ipa) * frqsumi csite%ebudget_loss2runoff(ipa) = csite%ebudget_loss2runoff(ipa) * frqsumi @@ -393,7 +392,6 @@ subroutine reset_averaged_vars(cgrid) cgrid%avg_runoff (ipy) = 0.0 cgrid%avg_drainage (ipy) = 0.0 cgrid%avg_drainage_heat (ipy) = 0.0 - cgrid%aux (ipy) = 0.0 cgrid%avg_carbon_ac (ipy) = 0.0 cgrid%avg_carbon_st (ipy) = 0.0 cgrid%avg_sensible_lc (ipy) = 0.0 @@ -405,7 +403,6 @@ subroutine reset_averaged_vars(cgrid) cgrid%avg_sensible_ac (ipy) = 0.0 cgrid%avg_runoff_heat (ipy) = 0.0 - cgrid%aux_s (:,ipy) = 0.0 cgrid%avg_smoist_gg (:,ipy) = 0.0 cgrid%avg_transloss (:,ipy) = 0.0 cgrid%avg_sensible_gg (:,ipy) = 0.0 @@ -508,6 +505,7 @@ subroutine reset_averaged_vars(cgrid) csite%ebudget_loss2runoff(ipa) = 0.0 csite%ebudget_loss2drainage(ipa) = 0.0 csite%ebudget_denseffect(ipa) = 0.0 + csite%ebudget_prsseffect(ipa) = 0.0 csite%ebudget_residual(ipa) = 0.0 !----------------------------------------------------------------! @@ -550,8 +548,6 @@ subroutine reset_averaged_vars(cgrid) csite%avg_runoff_heat(ipa) = 0.0 csite%avg_rk4step(ipa) = 0.0 csite%avg_available_water(ipa) = 0.0 - csite%aux(ipa) = 0.0 - csite%aux_s(:,ipa) = 0.0 csite%mean_rh(ipa) = 0.0 cohortloop: do ico=1,cpatch%ncohorts @@ -785,12 +781,6 @@ subroutine integrate_ed_daily_output_state(cgrid) cpatch%dmean_light_level_diff(ico) = & cpatch%dmean_light_level_diff(ico) & + cpatch%light_level_diff(ico) - cpatch%dmean_beamext_level(ico) = cpatch%dmean_beamext_level(ico) & - + cpatch%beamext_level(ico) - cpatch%dmean_diffext_level(ico) = cpatch%dmean_diffext_level(ico) & - + cpatch%diffext_level(ico) - cpatch%dmean_lambda_light(ico) = cpatch%dmean_lambda_light(ico) & - + cpatch%lambda_light(ico) end if !------------------------------------------------------------------------! @@ -824,11 +814,6 @@ subroutine integrate_ed_daily_output_state(cgrid) end if end do - - if (rshort_tot > rshort_twilight_min) then - csite%dmean_lambda_light(ipa) = csite%dmean_lambda_light(ipa) & - + csite%lambda_light(ipa) - end if end do patchloop !---------------------------------------------------------------------------------! @@ -2020,19 +2005,17 @@ subroutine normalize_ed_daily_output_vars(cgrid) , n_dbh & ! intent(in) , n_age & ! intent(in) , n_dist_types ! ! intent(in) - use consts_coms , only : cpi & ! intent(in) - , alvl & ! intent(in) - , day_sec & ! intent(in) + use consts_coms , only : day_sec & ! intent(in) , umols_2_kgCyr & ! intent(in) - , yr_day & ! intent(in) - , p00i & ! intent(in) - , rocp ! ! intent(in) + , yr_day ! ! intent(in) use ed_misc_coms , only : dtlsm & ! intent(in) , frqsum & ! intent(in) , ddbhi & ! intent(in) , dagei ! ! intent(in) use pft_coms , only : init_density ! ! intent(in) - use therm_lib , only : qwtk & ! subroutine + use therm_lib , only : press2exner & ! function + , extheta2temp & ! function + , uextcm2tl & ! subroutine , idealdenssh ! ! function implicit none !----- Arguments. ----------------------------------------------------------------------! @@ -2067,6 +2050,7 @@ subroutine normalize_ed_daily_output_vars(cgrid) real :: sss_albedo_beam real :: sss_albedo_diffuse real :: veg_fliq + real :: dmean_can_exner real :: dtlsm_o_daylight real :: frqsum_o_daylight !----- Locally saved variables. --------------------------------------------------------! @@ -2087,11 +2071,9 @@ subroutine normalize_ed_daily_output_vars(cgrid) do ipy=1,cgrid%npolygons cpoly => cgrid%polygon(ipy) cgrid%lai_pft (:,ipy) = 0. - cgrid%wpa_pft (:,ipy) = 0. cgrid%wai_pft (:,ipy) = 0. do isi=1,cpoly%nsites cpoly%lai_pft (:,isi) = 0. - cpoly%wpa_pft (:,isi) = 0. cpoly%wai_pft (:,isi) = 0. end do end do @@ -2130,8 +2112,9 @@ subroutine normalize_ed_daily_output_vars(cgrid) !------------------------------------------------------------------------------------! ! Find the canopy variables that are not conserved when pressure changes. ! !------------------------------------------------------------------------------------! - cgrid%dmean_can_temp(ipy) = cgrid%dmean_can_theta(ipy) & - * (p00i * cgrid%dmean_can_prss(ipy)) ** rocp + dmean_can_exner = press2exner(cgrid%dmean_can_prss(ipy)) + cgrid%dmean_can_temp(ipy) = extheta2temp( dmean_can_exner & + , cgrid%dmean_can_theta(ipy) ) cgrid%dmean_can_rhos(ipy) = idealdenssh (cgrid%dmean_can_prss(ipy) & ,cgrid%dmean_can_temp(ipy) & ,cgrid%dmean_can_shv (ipy) ) @@ -2142,8 +2125,8 @@ subroutine normalize_ed_daily_output_vars(cgrid) !----- Find the leaf temperature, only when the mean heat capacity is non-zero. -----! if (cgrid%dmean_leaf_hcap(ipy) > 0.) then - call qwtk(cgrid%dmean_leaf_energy(ipy),cgrid%dmean_leaf_water(ipy) & - ,cgrid%dmean_leaf_hcap(ipy),cgrid%dmean_leaf_temp(ipy),veg_fliq) + call uextcm2tl(cgrid%dmean_leaf_energy(ipy),cgrid%dmean_leaf_water(ipy) & + ,cgrid%dmean_leaf_hcap(ipy),cgrid%dmean_leaf_temp(ipy),veg_fliq) else cgrid%dmean_leaf_temp(ipy) = cgrid%dmean_gnd_temp(ipy) end if @@ -2154,8 +2137,8 @@ subroutine normalize_ed_daily_output_vars(cgrid) !----- Find the leaf temperature, only when the mean heat capacity is non-zero. -----! if (cgrid%dmean_wood_hcap(ipy) > 0.) then - call qwtk(cgrid%dmean_wood_energy(ipy),cgrid%dmean_wood_water(ipy) & - ,cgrid%dmean_wood_hcap(ipy),cgrid%dmean_wood_temp(ipy),veg_fliq) + call uextcm2tl(cgrid%dmean_wood_energy(ipy),cgrid%dmean_wood_water(ipy) & + ,cgrid%dmean_wood_hcap(ipy),cgrid%dmean_wood_temp(ipy),veg_fliq) else cgrid%dmean_wood_temp(ipy) = cgrid%dmean_gnd_temp(ipy) end if @@ -2322,12 +2305,6 @@ subroutine normalize_ed_daily_output_vars(cgrid) * dtlsm_o_daylight cpatch%dmean_light_level_diff(ico) = cpatch%dmean_light_level_diff(ico) & * dtlsm_o_daylight - cpatch%dmean_beamext_level (ico) = cpatch%dmean_beamext_level (ico) & - * dtlsm_o_daylight - cpatch%dmean_diffext_level (ico) = cpatch%dmean_diffext_level (ico) & - * dtlsm_o_daylight - cpatch%dmean_lambda_light (ico) = cpatch%dmean_lambda_light (ico) & - * dtlsm_o_daylight else cpatch%dmean_fs_open (ico) = 0. cpatch%dmean_fsw (ico) = 0. @@ -2338,9 +2315,6 @@ subroutine normalize_ed_daily_output_vars(cgrid) cpatch%dmean_light_level (ico) = 0. cpatch%dmean_light_level_beam(ico) = 0. cpatch%dmean_light_level_diff(ico) = 0. - cpatch%dmean_beamext_level (ico) = 0. - cpatch%dmean_diffext_level (ico) = 0. - cpatch%dmean_lambda_light (ico) = 0. end if end do cohortloop @@ -2377,17 +2351,7 @@ subroutine normalize_ed_daily_output_vars(cgrid) * frqsum_o_daysec csite%dmean_rk4step(ipa) = csite%dmean_rk4step(ipa) & * frqsum_o_daysec - !------------------------------------------------------------------------------! - ! The light level is averaged over the length of day light only. We find ! - ! this variable only if there is any day light (this is to avoid problems with ! - ! polar nights). ! - !------------------------------------------------------------------------------! - if (cpoly%daylight(isi) >= dtlsm) then - csite%dmean_lambda_light(ipa) = csite%dmean_lambda_light(ipa) & - * dtlsm / cpoly%daylight(isi) - else - csite%dmean_lambda_light(ipa) = 0.0 - end if + !------------------------------------------------------------------------------! ! Heterotrophic respiration is currently the integral over a day, given ! ! in µmol(CO2)/m²/s, so we multiply by the number of seconds in a year and ! @@ -2420,9 +2384,6 @@ subroutine normalize_ed_daily_output_vars(cgrid) cpoly%lai_pft(ipft,isi) = cpoly%lai_pft(ipft,isi) & + sum(cpatch%lai,cpatch%pft == ipft) & * csite%area(ipa) * site_area_i - cpoly%wpa_pft(ipft,isi) = cpoly%wpa_pft(ipft,isi) & - + sum(cpatch%wpa,cpatch%pft == ipft) & - * csite%area(ipa) * site_area_i cpoly%wai_pft(ipft,isi) = cpoly%wai_pft(ipft,isi) & + sum(cpatch%wai,cpatch%pft == ipft) & * csite%area(ipa) * site_area_i @@ -2466,8 +2427,6 @@ subroutine normalize_ed_daily_output_vars(cgrid) do ipft=1,n_pft cgrid%lai_pft(ipft,ipy) = cgrid%lai_pft(ipft,ipy) & + sum(cpoly%lai_pft(ipft,:)*cpoly%area) * poly_area_i - cgrid%wpa_pft(ipft,ipy) = cgrid%wpa_pft(ipft,ipy) & - + sum(cpoly%wpa_pft(ipft,:)*cpoly%area) * poly_area_i cgrid%wai_pft(ipft,ipy) = cgrid%wai_pft(ipft,ipy) & + sum(cpoly%wai_pft(ipft,:)*cpoly%area) * poly_area_i end do @@ -2671,7 +2630,6 @@ subroutine zero_ed_daily_output_vars(cgrid) cgrid%dmean_atm_prss (ipy) = 0. cgrid%dmean_atm_vels (ipy) = 0. cgrid%lai_pft (:,ipy) = 0. - cgrid%wpa_pft (:,ipy) = 0. cgrid%wai_pft (:,ipy) = 0. cgrid%dmean_co2_residual (ipy) = 0. cgrid%dmean_energy_residual(ipy) = 0. @@ -2682,7 +2640,6 @@ subroutine zero_ed_daily_output_vars(cgrid) csite => cpoly%site(isi) cpoly%lai_pft (:,isi) = 0. - cpoly%wpa_pft (:,isi) = 0. cpoly%wai_pft (:,isi) = 0. cpoly%dmean_co2_residual (isi) = 0. cpoly%dmean_energy_residual (isi) = 0. @@ -2695,7 +2652,6 @@ subroutine zero_ed_daily_output_vars(cgrid) csite%dmean_water_residual (ipa) = 0. csite%dmean_rh (ipa) = 0. csite%dmean_rk4step (ipa) = 0. - csite%dmean_lambda_light (ipa) = 0. csite%dmean_A_decomp (ipa) = 0. csite%dmean_Af_decomp (ipa) = 0. csite%dmean_albedo (ipa) = 0. @@ -2726,9 +2682,6 @@ subroutine zero_ed_daily_output_vars(cgrid) cpatch%dmean_light_level(ico) = 0. cpatch%dmean_light_level_beam(ico) = 0. cpatch%dmean_light_level_diff(ico) = 0. - cpatch%dmean_beamext_level(ico) = 0. - cpatch%dmean_diffext_level(ico) = 0. - cpatch%dmean_lambda_light(ico) = 0. end do end do end do @@ -2856,8 +2809,6 @@ subroutine integrate_ed_monthly_output_vars(cgrid) cgrid%mmean_lai_pft (:,ipy) = cgrid%mmean_lai_pft (:,ipy) & + cgrid%lai_pft (:,ipy) - cgrid%mmean_wpa_pft (:,ipy) = cgrid%mmean_wpa_pft (:,ipy) & - + cgrid%wpa_pft (:,ipy) cgrid%mmean_wai_pft (:,ipy) = cgrid%mmean_wai_pft (:,ipy) & + cgrid%wai_pft (:,ipy) @@ -3008,9 +2959,6 @@ subroutine integrate_ed_monthly_output_vars(cgrid) csite%mmean_rk4step(ipa) = csite%mmean_rk4step(ipa) & + csite%dmean_rk4step(ipa) - csite%mmean_lambda_light(ipa) = csite%mmean_lambda_light(ipa) & - + csite%dmean_lambda_light(ipa) - cpatch => csite%patch(ipa) cohort_loop: do ico=1,cpatch%ncohorts cpatch%mmean_fs_open (ico) = cpatch%mmean_fs_open (ico) & @@ -3063,12 +3011,6 @@ subroutine integrate_ed_monthly_output_vars(cgrid) + cpatch%dmean_light_level_beam(ico) cpatch%mmean_light_level_diff(ico) = cpatch%mmean_light_level_diff(ico) & + cpatch%dmean_light_level_diff(ico) - cpatch%mmean_beamext_level(ico) = cpatch%mmean_beamext_level(ico) & - + cpatch%dmean_beamext_level(ico) - cpatch%mmean_diffext_level(ico) = cpatch%mmean_diffext_level(ico) & - + cpatch%dmean_diffext_level(ico) - cpatch%mmean_lambda_light(ico) = cpatch%mmean_lambda_light(ico) & - + cpatch%dmean_lambda_light(ico) !----- Mortality rates. ----------------------------------------------------! do imt=1,n_mort @@ -3115,16 +3057,16 @@ subroutine normalize_ed_monthly_output_vars(cgrid) , n_age & ! intent(in) , n_dist_types & ! intent(in) , n_mort ! ! intent(in) - use consts_coms , only : p00i & ! intent(in) - , rocp & ! intent(in) - , pio4 & ! intent(in) + use consts_coms , only : pio4 & ! intent(in) , umol_2_kgC & ! intent(in) , umols_2_kgCyr & ! intent(in) , day_sec & ! intent(in) , yr_day ! ! intent(in) use pft_coms , only : init_density ! ! intent(in) - use therm_lib , only : idealdenssh & ! function - , qwtk ! ! function + use therm_lib , only : press2exner & ! function + , extheta2temp & ! function + , idealdenssh & ! function + , uextcm2tl ! ! function use allometry , only : ed_biomass ! ! function implicit none @@ -3167,6 +3109,8 @@ subroutine normalize_ed_monthly_output_vars(cgrid) logical :: forest real :: veg_fliq real :: cohort_seeds + real :: mmean_can_exner + real :: qmean_can_exner !----- Locally saved variables. --------------------------------------------------------! logical , save :: find_factors = .true. real , save :: dtlsm_o_frqfast = 1.e34 @@ -3266,7 +3210,6 @@ subroutine normalize_ed_monthly_output_vars(cgrid) cgrid%mmean_runoff (ipy) = cgrid%mmean_runoff (ipy) * ndaysi cgrid%mmean_drainage (ipy) = cgrid%mmean_drainage (ipy) * ndaysi cgrid%mmean_lai_pft (:,ipy) = cgrid%mmean_lai_pft (:,ipy) * ndaysi - cgrid%mmean_wpa_pft (:,ipy) = cgrid%mmean_wpa_pft (:,ipy) * ndaysi cgrid%mmean_wai_pft (:,ipy) = cgrid%mmean_wai_pft (:,ipy) * ndaysi cgrid%mmean_co2_residual(ipy) = cgrid%mmean_co2_residual(ipy) * ndaysi @@ -3311,8 +3254,9 @@ subroutine normalize_ed_monthly_output_vars(cgrid) !------------------------------------------------------------------------------------! ! Mean canopy air properties. ! !------------------------------------------------------------------------------------! - cgrid%mmean_can_temp (ipy) = cgrid%mmean_can_theta(ipy) & - * (p00i * cgrid%mmean_can_prss(ipy)) ** rocp + mmean_can_exner = press2exner(cgrid%mmean_can_prss(ipy)) + cgrid%mmean_can_temp (ipy) = extheta2temp( mmean_can_exner & + , cgrid%mmean_can_theta(ipy) ) cgrid%mmean_can_rhos (ipy) = idealdenssh (cgrid%mmean_can_prss(ipy) & ,cgrid%mmean_can_temp(ipy) & ,cgrid%mmean_can_shv (ipy) ) @@ -3325,14 +3269,14 @@ subroutine normalize_ed_monthly_output_vars(cgrid) ! there is some heat storage. ! !------------------------------------------------------------------------------------! if (cgrid%mmean_leaf_hcap(ipy) > 0.) then - call qwtk(cgrid%mmean_leaf_energy(ipy),cgrid%mmean_leaf_water(ipy) & - ,cgrid%mmean_leaf_hcap(ipy),cgrid%mmean_leaf_temp(ipy),veg_fliq) + call uextcm2tl(cgrid%mmean_leaf_energy(ipy),cgrid%mmean_leaf_water(ipy) & + ,cgrid%mmean_leaf_hcap(ipy),cgrid%mmean_leaf_temp(ipy),veg_fliq) else cgrid%mmean_leaf_temp(ipy) = cgrid%mmean_can_temp(ipy) end if if (cgrid%mmean_wood_hcap(ipy) > 0.) then - call qwtk(cgrid%mmean_wood_energy(ipy),cgrid%mmean_wood_water(ipy) & - ,cgrid%mmean_wood_hcap(ipy),cgrid%mmean_wood_temp(ipy),veg_fliq) + call uextcm2tl(cgrid%mmean_wood_energy(ipy),cgrid%mmean_wood_water(ipy) & + ,cgrid%mmean_wood_hcap(ipy),cgrid%mmean_wood_temp(ipy),veg_fliq) else cgrid%mmean_wood_temp(ipy) = cgrid%mmean_can_temp(ipy) end if @@ -3416,7 +3360,6 @@ subroutine normalize_ed_monthly_output_vars(cgrid) csite%mmean_water_residual(ipa) = csite%mmean_water_residual(ipa) * ndaysi csite%mmean_rh(ipa) = csite%mmean_rh(ipa) * ndaysi csite%mmean_rk4step(ipa) = csite%mmean_rk4step(ipa) * ndaysi - csite%mmean_lambda_light(ipa) = csite%mmean_lambda_light(ipa) * ndaysi csite%mmean_A_decomp(ipa) = csite%mmean_A_decomp(ipa) * ndaysi csite%mmean_Af_decomp(ipa) = csite%mmean_Af_decomp(ipa) * ndaysi csite%mmean_albedo(ipa) = csite%mmean_albedo(ipa) * ndaysi @@ -3474,12 +3417,6 @@ subroutine normalize_ed_monthly_output_vars(cgrid) * ndaysi cpatch%mmean_light_level_diff (ico) = cpatch%mmean_light_level_diff(ico) & * ndaysi - cpatch%mmean_beamext_level (ico) = cpatch%mmean_beamext_level(ico) & - * ndaysi - cpatch%mmean_diffext_level (ico) = cpatch%mmean_diffext_level(ico) & - * ndaysi - cpatch%mmean_lambda_light(ico) = cpatch%mmean_lambda_light(ico) & - * ndaysi !----- Define to which PFT this cohort belongs. ----------------------------! ipft = cpatch%pft(ico) @@ -3758,8 +3695,9 @@ subroutine normalize_ed_monthly_output_vars(cgrid) !------------------------------------------------------------------------------! ! Find the derived average propertiesof the canopy air space. ! !------------------------------------------------------------------------------! - cgrid%qmean_can_temp (t,ipy) = cgrid%qmean_can_theta(t,ipy) & - * (p00i * cgrid%qmean_can_prss(t,ipy)) ** rocp + qmean_can_exner = press2exner (cgrid%qmean_can_prss(t,ipy)) + cgrid%qmean_can_temp (t,ipy) = extheta2temp( qmean_can_exner & + , cgrid%qmean_can_theta(t,ipy) ) cgrid%qmean_can_rhos (t,ipy) = idealdenssh (cgrid%qmean_can_prss(t,ipy) & ,cgrid%qmean_can_temp(t,ipy) & ,cgrid%qmean_can_shv (t,ipy)) @@ -3771,16 +3709,16 @@ subroutine normalize_ed_monthly_output_vars(cgrid) ! canopy air space temperature. ! !------------------------------------------------------------------------------! if (cgrid%qmean_leaf_hcap(t,ipy) > 0.) then - call qwtk(cgrid%qmean_leaf_energy(t,ipy),cgrid%qmean_leaf_water(t,ipy) & - ,cgrid%qmean_leaf_hcap(t,ipy),cgrid%qmean_leaf_temp(t,ipy) & - ,veg_fliq) + call uextcm2tl(cgrid%qmean_leaf_energy(t,ipy),cgrid%qmean_leaf_water(t,ipy) & + ,cgrid%qmean_leaf_hcap(t,ipy),cgrid%qmean_leaf_temp(t,ipy) & + ,veg_fliq) else cgrid%qmean_leaf_temp(t,ipy) = cgrid%qmean_can_temp (t,ipy) end if if (cgrid%qmean_wood_hcap(t,ipy) > 0.) then - call qwtk(cgrid%qmean_wood_energy(t,ipy),cgrid%qmean_wood_water(t,ipy) & - ,cgrid%qmean_wood_hcap(t,ipy),cgrid%qmean_wood_temp(t,ipy) & - ,veg_fliq) + call uextcm2tl(cgrid%qmean_wood_energy(t,ipy),cgrid%qmean_wood_water(t,ipy) & + ,cgrid%qmean_wood_hcap(t,ipy),cgrid%qmean_wood_temp(t,ipy) & + ,veg_fliq) else cgrid%qmean_wood_temp(t,ipy) = cgrid%qmean_can_temp (t,ipy) end if @@ -3901,7 +3839,6 @@ subroutine zero_ed_monthly_output_vars(cgrid) cgrid%mmean_runoff (ipy) = 0. cgrid%mmean_drainage (ipy) = 0. cgrid%mmean_lai_pft (:,ipy) = 0. - cgrid%mmean_wpa_pft (:,ipy) = 0. cgrid%mmean_wai_pft (:,ipy) = 0. cgrid%agb_pft (:,ipy) = 0. cgrid%ba_pft (:,ipy) = 0. @@ -3943,7 +3880,6 @@ subroutine zero_ed_monthly_output_vars(cgrid) csite%mmean_water_residual (ipa) = 0. csite%mmean_rh (ipa) = 0. csite%mmean_rk4step (ipa) = 0. - csite%mmean_lambda_light (ipa) = 0. csite%mmean_A_decomp (ipa) = 0. csite%mmean_Af_decomp (ipa) = 0. csite%mmean_albedo (ipa) = 0. @@ -3980,9 +3916,6 @@ subroutine zero_ed_monthly_output_vars(cgrid) cpatch%mmean_light_level (ico) = 0. cpatch%mmean_light_level_beam (ico) = 0. cpatch%mmean_light_level_diff (ico) = 0. - cpatch%mmean_beamext_level (ico) = 0. - cpatch%mmean_diffext_level (ico) = 0. - cpatch%mmean_lambda_light (ico) = 0. cpatch%mmean_mort_rate (:,ico) = 0. end do end do diff --git a/ED/src/io/ed_init_full_history.F90 b/ED/src/io/ed_init_full_history.F90 index 4ca5091b7..3c29839db 100644 --- a/ED/src/io/ed_init_full_history.F90 +++ b/ED/src/io/ed_init_full_history.F90 @@ -537,7 +537,6 @@ end subroutine hdf_getslab_i call hdf_getslab_r(cgrid%lai (ipy:ipy),'LAI ',dsetrank,iparallel,.true.) call hdf_getslab_r(cgrid%wai (ipy:ipy),'WAI ',dsetrank,iparallel,.true.) - call hdf_getslab_r(cgrid%wpa (ipy:ipy),'WPA ',dsetrank,iparallel,.true.) call hdf_getslab_r(cgrid%avg_lma(ipy:ipy),'AVG_LMA ',dsetrank,iparallel,.false.) call hdf_getslab_r(cgrid%runoff(ipy:ipy),'RUNOFF ',dsetrank,iparallel,.true.) @@ -1567,14 +1566,10 @@ end subroutine hdf_getslab_i dsetrank,iparallel,.false.) if(associated(cgrid%lai_pft)) call hdf_getslab_r(cgrid%lai_pft(:,ipy) ,'LAI_PFT ' , & dsetrank,iparallel,.false.) - if(associated(cgrid%wpa_pft)) call hdf_getslab_r(cgrid%wpa_pft(:,ipy) ,'WPA_PFT ' , & - dsetrank,iparallel,.false.) if(associated(cgrid%wai_pft)) call hdf_getslab_r(cgrid%wai_pft(:,ipy) ,'WAI_PFT ' , & dsetrank,iparallel,.false.) if(associated(cgrid%mmean_lai_pft)) call hdf_getslab_r(cgrid%mmean_lai_pft(:,ipy) ,'MMEAN_LAI_PFT ' , & dsetrank,iparallel,.false.) - if(associated(cgrid%mmean_wpa_pft)) call hdf_getslab_r(cgrid%mmean_wpa_pft(:,ipy) ,'MMEAN_WPA_PFT ' , & - dsetrank,iparallel,.false.) if(associated(cgrid%mmean_wai_pft)) call hdf_getslab_r(cgrid%mmean_wai_pft(:,ipy) ,'MMEAN_WAI_PFT ' , & dsetrank,iparallel,.false.) if(associated(cgrid%agb_pft)) call hdf_getslab_r(cgrid%agb_pft(:,ipy) ,'AGB_PFT ' , & @@ -1880,8 +1875,6 @@ end subroutine hdf_getslab_i if (associated(cpoly%lai_pft)) call hdf_getslab_r(cpoly%lai_pft,'LAI_PFT_SI ', & dsetrank,iparallel,.false.) - if (associated(cpoly%wpa_pft)) call hdf_getslab_r(cpoly%wpa_pft,'WPA_PFT_SI ', & - dsetrank,iparallel,.false.) if (associated(cpoly%wai_pft)) call hdf_getslab_r(cpoly%wai_pft,'WAI_PFT_SI ', & dsetrank,iparallel,.false.) call hdf_getslab_r(cpoly%green_leaf_factor,'GREEN_LEAF_FACTOR ', & @@ -1989,7 +1982,6 @@ subroutine fill_history_site(csite,sipa_index,npatches_global) use ed_state_vars,only: sitetype use grid_coms,only : nzg,nzs - use c34constants,only:n_stoma_atts use ed_max_dims,only : n_pft,n_dbh use hdf5_coms,only:file_id,dset_id,dspace_id,plist_id, & globdims,chnkdims,chnkoffs,cnt,stride, & @@ -2077,6 +2069,7 @@ end subroutine hdf_getslab_i call hdf_getslab_r(csite%can_prss,'CAN_PRSS ',dsetrank,iparallel,.true.) call hdf_getslab_r(csite%can_theta,'CAN_THETA ',dsetrank,iparallel,.true.) call hdf_getslab_r(csite%can_temp,'CAN_TEMP ',dsetrank,iparallel,.true.) + call hdf_getslab_r(csite%can_temp_pv,'CAN_TEMP_PV ',dsetrank,iparallel,.false.) call hdf_getslab_r(csite%can_shv,'CAN_SHV ',dsetrank,iparallel,.true.) call hdf_getslab_r(csite%can_co2,'CAN_CO2 ',dsetrank,iparallel,.true.) call hdf_getslab_r(csite%can_rhos,'CAN_RHOS ',dsetrank,iparallel,.true.) @@ -2088,7 +2081,6 @@ end subroutine hdf_getslab_i call hdf_getslab_r(csite%opencan_frac,'OPENCAN_FRAC ',dsetrank,iparallel,.false.) ! call hdf_getslab_i(csite%pname,'PNAME ',dsetrank,iparallel) call hdf_getslab_r(csite%lai,'LAI_PA ',dsetrank,iparallel,.true.) - call hdf_getslab_r(csite%wpa,'WPA_PA ',dsetrank,iparallel,.false.) call hdf_getslab_r(csite%wai,'WAI_PA ',dsetrank,iparallel,.false.) call hdf_getslab_i(csite%nlev_sfcwater,'NLEV_SFCWATER ',dsetrank,iparallel,.true.) call hdf_getslab_r(csite%ground_shv ,'GROUND_SHV ',dsetrank,iparallel,.false.) @@ -2119,14 +2111,6 @@ end subroutine hdf_getslab_i if (associated(csite%mmean_albedo_diffuse )) & call hdf_getslab_r(csite%mmean_albedo_diffuse,'MMEAN_ALBEDO_DIFFUSE_PA ',dsetrank,iparallel,.false.) - call hdf_getslab_r(csite%lambda_light,'LAMBDA_LIGHT ',dsetrank,iparallel,.true.) - - if (associated(csite%dmean_lambda_light )) & - call hdf_getslab_r(csite%dmean_lambda_light,'DMEAN_LAMBDA_LIGHT ',dsetrank,iparallel,.false.) - - if (associated(csite%mmean_lambda_light )) & - call hdf_getslab_r(csite%mmean_lambda_light,'MMEAN_LAMBDA_LIGHT ',dsetrank,iparallel,.false.) - call hdf_getslab_r(csite%mean_nep,'MEAN_NEP ',dsetrank,iparallel,.true.) call hdf_getslab_r(csite%wbudget_loss2atm,'WBUDGET_LOSS2ATM ',dsetrank,iparallel,.true.) @@ -2136,6 +2120,7 @@ end subroutine hdf_getslab_i call hdf_getslab_r(csite%wbudget_initialstorage,'WBUDGET_INITIALSTORAGE ',dsetrank,iparallel,.true.) call hdf_getslab_r(csite%ebudget_loss2atm,'EBUDGET_LOSS2ATM ',dsetrank,iparallel,.true.) call hdf_getslab_r(csite%ebudget_denseffect,'EBUDGET_DENSEFFECT ',dsetrank,iparallel,.true.) + call hdf_getslab_r(csite%ebudget_prsseffect,'EBUDGET_PRSSEFFECT ',dsetrank,iparallel,.false.) call hdf_getslab_r(csite%ebudget_loss2runoff,'EBUDGET_LOSS2RUNOFF ',dsetrank,iparallel,.true.) call hdf_getslab_r(csite%ebudget_netrad,'EBUDGET_NETRAD ',dsetrank,iparallel,.true.) call hdf_getslab_r(csite%ebudget_precipgain,'EBUDGET_PRECIPGAIN ',dsetrank,iparallel,.true.) @@ -2193,7 +2178,6 @@ end subroutine hdf_getslab_i call hdf_getslab_r(csite%f_decomp,'F_DECOMP ',dsetrank,iparallel,.true.) call hdf_getslab_r(csite%rh,'RH ',dsetrank,iparallel,.true.) call hdf_getslab_r(csite%cwd_rh,'CWD_RH ',dsetrank,iparallel,.true.) - call hdf_getslab_i(csite%fuse_flag,'FUSE_FLAG ',dsetrank,iparallel,.true.) call hdf_getslab_r(csite%plant_ag_biomass,'PLANT_AG_BIOMASS ',dsetrank,iparallel,.true.) call hdf_getslab_r(csite%mean_wflux,'MEAN_WFLUX ',dsetrank,iparallel,.true.) call hdf_getslab_r(csite%mean_latflux,'MEAN_LATFLUX ',dsetrank,iparallel,.true.) @@ -2201,6 +2185,13 @@ end subroutine hdf_getslab_i call hdf_getslab_r(csite%mean_runoff,'MEAN_RUNOFF ',dsetrank,iparallel,.true.) call hdf_getslab_r(csite%mean_qrunoff,'MEAN_QRUNOFF ',dsetrank,iparallel,.true.) call hdf_getslab_r(csite%htry,'HTRY ',dsetrank,iparallel,.true.) + call hdf_getslab_r(csite%hprev,'HPREV ',dsetrank,iparallel,.false.) + + if(csite%hprev(1) < 1.0d-10)then + csite%hprev=csite%htry + end if + + if (associated(csite%dmean_rk4step)) & call hdf_getslab_r(csite%dmean_rk4step,'DMEAN_RK4STEP ',dsetrank,iparallel,.false.) if (associated(csite%mmean_rk4step)) & @@ -2253,6 +2244,8 @@ end subroutine hdf_getslab_i ,dsetrank,iparallel,.true.) call hdf_getslab_r(csite%ebudget_denseffect ,'EBUDGET_DENSEFFECT ' & ,dsetrank,iparallel,.true.) + call hdf_getslab_r(csite%ebudget_prsseffect ,'EBUDGET_PRSSEFFECT ' & + ,dsetrank,iparallel,.false.) call hdf_getslab_r(csite%ebudget_loss2runoff ,'EBUDGET_LOSS2RUNOFF ' & ,dsetrank,iparallel,.true.) call hdf_getslab_r(csite%ebudget_loss2drainage ,'EBUDGET_LOSS2DRAINAGE ' & @@ -2447,9 +2440,6 @@ end subroutine hdf_getslab_i memoffs(2) = 0_8 call hdf_getslab_r(csite%co2budget_gpp_dbh,'CO2BUDGET_GPP_DBH ',dsetrank,iparallel,.true.) -!!!! MAY NEED TO ADD THIS ONE -! call hdf_getslab_r(csite%old_stoma_data_max,'OLD ',dsetrank,iparallel,.true.) - dsetrank = 3 globdims(3) = int(npatches_global,8) chnkdims(3) = int(csite%npatches,8) @@ -2475,54 +2465,6 @@ end subroutine hdf_getslab_i call hdf_getslab_r(csite%cumlai_profile,'CUMLAI_PROFILE ',dsetrank,iparallel,.false.) - - dsetrank = 3 - globdims(3) = int(npatches_global,8) - chnkdims(3) = int(csite%npatches,8) - chnkoffs(3) = int(sipa_index - 1,8) - - memdims(3) = int(csite%npatches,8) - memsize(3) = int(csite%npatches,8) - memoffs(3) = 0_8 - - globdims(2) = int(n_pft,8) - chnkdims(2) = int(n_pft,8) - memdims(2) = int(n_pft,8) - memsize(2) = int(n_pft,8) - chnkoffs(2) = 0_8 - memoffs(2) = 0_8 - - globdims(1) = int(n_stoma_atts,8) - chnkdims(1) = int(n_stoma_atts,8) - memdims(1) = int(n_stoma_atts,8) - memsize(1) = int(n_stoma_atts,8) - chnkoffs(1) = 0_8 - memoffs(1) = 0_8 - - call hdf_getslab_r(csite%old_stoma_vector_max,'OLD_STOMA_VECTOR_MAX ',dsetrank,iparallel,.true.) - - patchloop: do ipa=1,csite%npatches - pftloop: do ipft = 1,n_pft - csite%old_stoma_data_max(ipft,ipa)%recalc = int(csite%old_stoma_vector_max(1,ipft,ipa)) - csite%old_stoma_data_max(ipft,ipa)%T_L = csite%old_stoma_vector_max(2,ipft,ipa) - csite%old_stoma_data_max(ipft,ipa)%e_A = csite%old_stoma_vector_max(3,ipft,ipa) - csite%old_stoma_data_max(ipft,ipa)%PAR = csite%old_stoma_vector_max(4,ipft,ipa) - csite%old_stoma_data_max(ipft,ipa)%rb_factor = csite%old_stoma_vector_max(5,ipft,ipa) - csite%old_stoma_data_max(ipft,ipa)%prss = csite%old_stoma_vector_max(6,ipft,ipa) - csite%old_stoma_data_max(ipft,ipa)%phenology_factor = csite%old_stoma_vector_max(7,ipft,ipa) - csite%old_stoma_data_max(ipft,ipa)%gsw_open = csite%old_stoma_vector_max(8,ipft,ipa) - csite%old_stoma_data_max(ipft,ipa)%ilimit = int(csite%old_stoma_vector_max(9,ipft,ipa)) - - csite%old_stoma_data_max(ipft,ipa)%T_L_residual = csite%old_stoma_vector_max(10,ipft,ipa) - csite%old_stoma_data_max(ipft,ipa)%e_a_residual = csite%old_stoma_vector_max(11,ipft,ipa) - csite%old_stoma_data_max(ipft,ipa)%par_residual = csite%old_stoma_vector_max(12,ipft,ipa) - csite%old_stoma_data_max(ipft,ipa)%rb_residual = csite%old_stoma_vector_max(13,ipft,ipa) - csite%old_stoma_data_max(ipft,ipa)%prss_residual= csite%old_stoma_vector_max(14,ipft,ipa) - csite%old_stoma_data_max(ipft,ipa)%leaf_residual= csite%old_stoma_vector_max(15,ipft,ipa) - csite%old_stoma_data_max(ipft,ipa)%gsw_residual = csite%old_stoma_vector_max(16,ipft,ipa) - end do pftloop - end do patchloop - return end subroutine fill_history_site @@ -2536,12 +2478,9 @@ subroutine fill_history_patch(cpatch,paco_index,ncohorts_global,green_leaf_facto filespace,memspace, & globdims,chnkdims,chnkoffs,cnt,stride, & memdims,memoffs,memsize - use consts_coms, only: cliq,cice,t3ple,tsupercool - use c34constants,only: n_stoma_atts use ed_max_dims,only: n_pft, n_mort use allometry, only : dbh2ca use ed_misc_coms, only : ndcycle - use therm_lib, only : qwtk implicit none #if USE_INTERF @@ -2628,7 +2567,6 @@ end subroutine hdf_getslab_i call hdf_getslab_r(cpatch%bstorage,'BSTORAGE ',dsetrank,iparallel,.true.) call hdf_getslab_r(cpatch%cbr_bar,'CBR_BAR ',dsetrank,iparallel,.true.) - call hdf_getslab_r(cpatch%wpa,'WPA_CO ',dsetrank,iparallel,.true.) call hdf_getslab_r(cpatch%wai,'WAI_CO ',dsetrank,iparallel,.true.) call hdf_getslab_r(cpatch%crown_area,'CROWN_AREA_CO ',dsetrank,iparallel,.false.) @@ -2642,11 +2580,13 @@ end subroutine hdf_getslab_i call hdf_getslab_r(cpatch%leaf_energy,'LEAF_ENERGY ',dsetrank,iparallel,.true.) call hdf_getslab_r(cpatch%leaf_hcap,'LEAF_HCAP ',dsetrank,iparallel,.true.) call hdf_getslab_r(cpatch%leaf_temp,'LEAF_TEMP ',dsetrank,iparallel,.true.) + call hdf_getslab_r(cpatch%leaf_temp_pv,'LEAF_TEMP_PV ',dsetrank,iparallel,.false.) call hdf_getslab_r(cpatch%leaf_water,'LEAF_WATER ',dsetrank,iparallel,.true.) call hdf_getslab_r(cpatch%leaf_fliq,'LEAF_FLIQ ',dsetrank,iparallel,.true.) call hdf_getslab_r(cpatch%wood_energy,'WOOD_ENERGY ',dsetrank,iparallel,.true.) call hdf_getslab_r(cpatch%wood_hcap,'WOOD_HCAP ',dsetrank,iparallel,.true.) call hdf_getslab_r(cpatch%wood_temp,'WOOD_TEMP ',dsetrank,iparallel,.true.) + call hdf_getslab_r(cpatch%wood_temp_pv,'WOOD_TEMP_PV ',dsetrank,iparallel,.false.) call hdf_getslab_r(cpatch%wood_water,'WOOD_WATER ',dsetrank,iparallel,.true.) call hdf_getslab_r(cpatch%wood_fliq,'WOOD_FLIQ ',dsetrank,iparallel,.true.) call hdf_getslab_r(cpatch%veg_wind,'VEG_WIND ',dsetrank,iparallel,.true.) @@ -2795,23 +2735,6 @@ end subroutine hdf_getslab_i call hdf_getslab_r(cpatch%mmean_par_l_beam,'MMEAN_PAR_L_BEAM ',dsetrank,iparallel,.false.) if (associated(cpatch%mmean_par_l_diff )) & call hdf_getslab_r(cpatch%mmean_par_l_diff,'MMEAN_PAR_L_DIFF ',dsetrank,iparallel,.false.) - if (associated(cpatch%dmean_beamext_level )) & - call hdf_getslab_r(cpatch%dmean_beamext_level,'DMEAN_BEAMEXT_LEVEL ',dsetrank,iparallel,.false.) - if (associated(cpatch%mmean_beamext_level )) & - call hdf_getslab_r(cpatch%mmean_beamext_level,'MMEAN_BEAMEXT_LEVEL ',dsetrank,iparallel,.false.) - - if (associated(cpatch%dmean_diffext_level )) & - call hdf_getslab_r(cpatch%dmean_diffext_level,'DMEAN_DIFFEXT_LEVEL ',dsetrank,iparallel,.false.) - - if (associated(cpatch%mmean_diffext_level )) & - call hdf_getslab_r(cpatch%mmean_diffext_level,'MMEAN_DIFFEXT_LEVEL ',dsetrank,iparallel,.false.) - - if (associated(cpatch%dmean_lambda_light )) & - call hdf_getslab_r(cpatch%dmean_lambda_light,'DMEAN_LAMBDA_LIGHT_CO ',dsetrank,iparallel,.false.) - - if (associated(cpatch%mmean_lambda_light )) & - call hdf_getslab_r(cpatch%mmean_lambda_light,'MMEAN_LAMBDA_LIGHT_CO ',dsetrank,iparallel,.false.) - call hdf_getslab_r(cpatch%Psi_open,'PSI_OPEN ',dsetrank,iparallel,.true.) call hdf_getslab_i(cpatch%krdepth,'KRDEPTH ',dsetrank,iparallel,.true.) call hdf_getslab_i(cpatch%first_census,'FIRST_CENSUS ',dsetrank,iparallel,.true.) @@ -2819,9 +2742,6 @@ end subroutine hdf_getslab_i call hdf_getslab_r(cpatch%light_level,'LIGHT_LEVEL ',dsetrank,iparallel,.true.) call hdf_getslab_r(cpatch%light_level_beam,'LIGHT_LEVEL_BEAM ',dsetrank,iparallel,.true.) call hdf_getslab_r(cpatch%light_level_diff,'LIGHT_LEVEL_DIFF ',dsetrank,iparallel,.true.) - call hdf_getslab_r(cpatch%beamext_level,'BEAMEXT_LEVEL ',dsetrank,iparallel,.true.) - call hdf_getslab_r(cpatch%diffext_level,'DIFFEXT_LEVEL ',dsetrank,iparallel,.true.) - call hdf_getslab_r(cpatch%lambda_light,'LAMBDA_LIGHT_CO ',dsetrank,iparallel,.true.) call hdf_getslab_r(cpatch%par_l,'PAR_L ',dsetrank,iparallel,.true.) call hdf_getslab_r(cpatch%par_l_beam,'PAR_L_BEAM ',dsetrank,iparallel,.true.) call hdf_getslab_r(cpatch%par_l_diffuse,'PAR_L_DIFFUSE ',dsetrank,iparallel,.true.) @@ -2967,46 +2887,6 @@ end subroutine hdf_getslab_i call hdf_getslab_r(cpatch%qmean_water_supply,'QMEAN_WATER_SUPPLY_CO ' & ,dsetrank,iparallel,.true.) - - dsetrank = 2 - globdims(1) = int(n_stoma_atts,8) - chnkdims(1) = int(n_stoma_atts,8) - chnkoffs(1) = 0_8 - memdims(1) = int(n_stoma_atts,8) - memsize(1) = int(n_stoma_atts,8) - memoffs(2) = 0_8 - - globdims(2) = int(ncohorts_global,8) - chnkdims(2) = int(cpatch%ncohorts,8) - chnkoffs(2) = int(paco_index - 1,8) - - memdims(2) = int(cpatch%ncohorts,8) - memsize(2) = int(cpatch%ncohorts,8) - memoffs(2) = 0_8 - - - call hdf_getslab_r(cpatch%old_stoma_vector,'OLD_STOMA_VECTOR', & - dsetrank,iparallel,.true.) - - cohortloop: do ico=1,cpatch%ncohorts - cpatch%old_stoma_data(ico)%recalc = int(cpatch%old_stoma_vector(1,ico)) - cpatch%old_stoma_data(ico)%T_L = cpatch%old_stoma_vector(2,ico) - cpatch%old_stoma_data(ico)%e_A = cpatch%old_stoma_vector(3,ico) - cpatch%old_stoma_data(ico)%PAR = cpatch%old_stoma_vector(4,ico) - cpatch%old_stoma_data(ico)%rb_factor = cpatch%old_stoma_vector(5,ico) - cpatch%old_stoma_data(ico)%prss = cpatch%old_stoma_vector(6,ico) - cpatch%old_stoma_data(ico)%phenology_factor = cpatch%old_stoma_vector(7,ico) - cpatch%old_stoma_data(ico)%gsw_open = cpatch%old_stoma_vector(8,ico) - cpatch%old_stoma_data(ico)%ilimit = int(cpatch%old_stoma_vector(9,ico)) - cpatch%old_stoma_data(ico)%T_L_residual = cpatch%old_stoma_vector(10,ico) - cpatch%old_stoma_data(ico)%e_a_residual = cpatch%old_stoma_vector(11,ico) - cpatch%old_stoma_data(ico)%par_residual = cpatch%old_stoma_vector(12,ico) - cpatch%old_stoma_data(ico)%rb_residual = cpatch%old_stoma_vector(13,ico) - cpatch%old_stoma_data(ico)%prss_residual= cpatch%old_stoma_vector(14,ico) - cpatch%old_stoma_data(ico)%leaf_residual= cpatch%old_stoma_vector(15,ico) - cpatch%old_stoma_data(ico)%gsw_residual = cpatch%old_stoma_vector(16,ico) - enddo cohortloop - endif diff --git a/ED/src/io/ed_load_namelist.f90 b/ED/src/io/ed_load_namelist.f90 index 17efd0e7b..7a577b0da 100644 --- a/ED/src/io/ed_load_namelist.f90 +++ b/ED/src/io/ed_load_namelist.f90 @@ -130,13 +130,15 @@ subroutine copy_nl(copy_type) use decomp_coms , only : n_decomp_lim & ! intent(out) , LloydTaylor ! ! intent(out) use disturb_coms , only : include_fire & ! intent(out) + , fire_parameter & ! intent(out) , ianth_disturb & ! intent(out) , treefall_disturbance_rate & ! intent(out) , lu_database & ! intent(out) , plantation_file & ! intent(out) , lu_rescale_file & ! intent(out) , sm_fire & ! intent(out) - , time2canopy ! ! intent(out) + , time2canopy & ! intent(out) + , min_patch_area ! ! intent(out) use pft_coms , only : include_these_pft & ! intent(out) , agri_stock & ! intent(out) , plantation_stock & ! intent(out) @@ -166,6 +168,7 @@ subroutine copy_nl(copy_type) , end_time & ! intent(out) , radfrq & ! intent(out) , ivegt_dynamics & ! intent(out) + , ibigleaf & ! intent(out) , integration_scheme & ! intent(out) , ffilout & ! intent(out) , idoutput & ! intent(out) @@ -234,6 +237,8 @@ subroutine copy_nl(copy_type) , ipercol & ! intent(out) , rk4_tolerance ! ! intent(out) use ed_para_coms , only : loadmeth ! ! intent(out) + use detailed_coms , only : idetailed & ! intent(out) + , patch_keep ! ! intent(out) use consts_coms , only : vonk & ! intent(in) , day_sec & ! intent(in) , hr_sec & ! intent(in) @@ -331,6 +336,7 @@ subroutine copy_nl(copy_type) ed_reg_lonmax = nl%ed_reg_lonmax ivegt_dynamics = nl%ivegt_dynamics + ibigleaf = nl%ibigleaf integration_scheme = nl%integration_scheme rk4_tolerance = nl%rk4_tolerance ibranch_thermo = nl%ibranch_thermo @@ -381,6 +387,7 @@ subroutine copy_nl(copy_type) n_plant_lim = nl%n_plant_lim n_decomp_lim = nl%n_decomp_lim include_fire = nl%include_fire + fire_parameter = nl%fire_parameter sm_fire = nl%sm_fire ianth_disturb = nl%ianth_disturb @@ -437,9 +444,13 @@ subroutine copy_nl(copy_type) maxpatch = nl%maxpatch maxcohort = nl%maxcohort min_site_area = nl%min_site_area + min_patch_area = nl%min_patch_area ioptinpt = nl%ioptinpt zrough = nl%zrough - + + idetailed = nl%idetailed + patch_keep = nl%patch_keep + nnxp = nl%nnxp nnyp = nl%nnyp diff --git a/ED/src/io/ed_opspec.F90 b/ED/src/io/ed_opspec.F90 index 1335b792a..53110f95c 100644 --- a/ED/src/io/ed_opspec.F90 +++ b/ED/src/io/ed_opspec.F90 @@ -500,6 +500,12 @@ subroutine ed_opspec_times ! Check outfast setting and adjusting it if needed. Depending on the ! ! configuration, this will cause the run to crash. ! !------------------------------------------------------------------------------------! + elseif (frqfast < 10*60) then + write(reason,fmt='(a,1x,a,1x,es14.7)') & + 'FRQFAST must be greater than 10min (600 sec) when daily and/or monthly' & + ,'analysis are on or you will create a memory leak. Yours is set to ',frqfast + call opspec_fatal(reason,'opspec_misc') + ifaterr = ifaterr +1 elseif(outfast == 0.) then !----- User didn't specify any outfast, use frqfast ------------------------------! outfast = frqfast @@ -909,8 +915,6 @@ subroutine ed_opspec_times !------------------------------------------------------------------------------------! elseif (outstate /= 0. .or. outstate > frqstate) then - outstate = frqstate - nrec_state = 1 write (unit=*,fmt='(a)') ' ' write (unit=*,fmt='(a)') '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' write (unit=*,fmt='(a)') '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' @@ -920,10 +924,14 @@ subroutine ed_opspec_times write (unit=*,fmt='(a)') ' -> Outstate cannot be different than frqstate when' write (unit=*,fmt='(a)') ' unitstate is set to 3 (years).' write (unit=*,fmt='(a,1x,f7.0,1x,a)') & - ' Oustate was redefined to ',outstate,'years.' + ' Oustate was set to ',outstate,'years.' + write (unit=*,fmt='(a,1x,f7.0,1x,a)') & + ' Oustate was redefined to ',frqstate,'years.' write (unit=*,fmt='(a)') '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' write (unit=*,fmt='(a)') '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' write (unit=*,fmt='(a)') ' ' + outstate = frqstate + nrec_state = 1 else !----- The user either knew or was lucky, don't print the banner ---------------! outstate = frqstate nrec_state = 1 @@ -1104,6 +1112,7 @@ subroutine ed_opspec_misc , runtype & ! intent(in) , ied_init_mode & ! intent(in) , ivegt_dynamics & ! intent(in) + , ibigleaf & ! intent(in) , integration_scheme & ! intent(in) , iallom & ! intent(in) , min_site_area ! ! intent(in) @@ -1162,11 +1171,14 @@ subroutine ed_opspec_misc , quantum_efficiency_T ! ! intent(in) use decomp_coms , only : n_decomp_lim ! ! intent(in) use disturb_coms , only : include_fire & ! intent(in) + , fire_parameter & ! intent(in) , ianth_disturb & ! intent(in) , sm_fire & ! intent(in) , time2canopy & ! intent(in) - , treefall_disturbance_rate ! ! intent(in) + , treefall_disturbance_rate & ! intent(in) + , min_patch_area ! ! intent(in) use phenology_coms , only : iphen_scheme & ! intent(in) + , repro_scheme & ! intent(in) , radint & ! intent(in) , radslp & ! intent(in) , thetacrit ! ! intent(in) @@ -1187,6 +1199,11 @@ subroutine ed_opspec_misc use rk4_coms , only : ibranch_thermo & ! intent(in) , ipercol & ! intent(in) , rk4_tolerance ! ! intent(in) + use mem_polygons , only : n_ed_region & ! intent(in) + , n_poi ! ! intent(in) + use detailed_coms , only : idetailed & ! intent(in) + , patch_keep ! ! intent(in) + use met_driver_coms , only : imetrad ! ! intent(in) #if defined(COUPLED) #else @@ -1197,8 +1214,12 @@ subroutine ed_opspec_misc implicit none !----- Local variables -----------------------------------------------------------------! character(len=str_len) :: reason - integer :: ifaterr,ifm,ipft - logical :: agri_ok,plantation_ok + integer :: ifaterr + integer :: ifm + integer :: ipft + logical :: agri_ok + logical :: plantation_ok + logical :: patch_detailed !----- Local constants -----------------------------------------------------------------! integer, parameter :: skip=huge(6) !---------------------------------------------------------------------------------------! @@ -1219,6 +1240,12 @@ subroutine ed_opspec_misc ,'Yours is set to ',min_site_area,'...' end if + if (min_patch_area < 0.000001 .or. min_patch_area > 0.02) then + write (reason,fmt='(a,2x,a,1x,es12.5,a)') & + 'Invalid MIN_PATCH_AREA, it must be between 0.000001 and 0.02.' & + ,'Yours is set to ',min_patch_area,'...' + end if + if (ifoutput /= 0 .and. ifoutput /= 3) then write (reason,fmt='(a,1x,i4,a)') & 'Invalid IFOUTPUT, it must be 0 (none) or 3 (HDF5). Yours is set to',ifoutput,'...' @@ -1276,6 +1303,19 @@ subroutine ed_opspec_misc end if if (ied_init_mode == -8) then + !------------------------------------------------------------------------------------! + ! The special 8-layer model works only in size- and age-structured runs. ! + !------------------------------------------------------------------------------------! + if (ibigleaf == 1) then + write (reason,fmt='(a)') & + 'IED_INIT_MODE can''t be -8 when running big leaf mode.' & + ,trim(runtype),'...' + call opspec_fatal(reason,'opspec_misc') + ifaterr = ifaterr +1 + end if + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! ! This is just for idealised test runs and shouldn't be used as a regular ! ! option. ! @@ -1447,13 +1487,25 @@ subroutine ed_opspec_misc ifaterr = ifaterr +1 end if + if (ibigleaf < 0 .or. ibigleaf > 1) then + write (reason,fmt='(a,1x,i4,a)') & + 'Invalid IBIGLEAF, it must be between 0 and 1. Yours is set to',ibigleaf,'...' + call opspec_fatal(reason,'opspec_misc') + ifaterr = ifaterr +1 + elseif (ibigleaf == 1 .and. crown_mod /= 0) then + write (reason,fmt='(a,1x,i4,a)') & + 'CROWN_MOD must be turned off when IBIGLEAF is set to 1...' + call opspec_fatal(reason,'opspec_misc') + ifaterr = ifaterr +1 + end if + !---------------------------------------------------------------------------------------! ! Integration scheme can be only 0 (Euler) or 1 (4th order Runge-Kutta). The ! ! branch thermodynamics is currently working only with Runge-Kutta, so we won't allow ! ! using it in case the user decides for Euler. ! !---------------------------------------------------------------------------------------! select case (integration_scheme) - case (0:2) + case (0:3) !------------------------------------------------------------------------------------! ! Check the branch thermodynamics. ! !------------------------------------------------------------------------------------! @@ -1508,6 +1560,14 @@ subroutine ed_opspec_misc ifaterr = ifaterr +1 end if + if (repro_scheme < 0 .or. repro_scheme > 3) then + write (reason,fmt='(a,1x,i4,a)') & + 'Invalid REPRO_SCHEME, it must be between 0 and 3. Yours is set to' & + ,repro_scheme,'...' + call opspec_fatal(reason,'opspec_misc') + ifaterr = ifaterr +1 + end if + if (radint < -100.0 .or. radint > 100.0) then write (reason,fmt='(a,1x,es12.5,a)') & 'Invalid RADINT, it must be between -100 and 100. Yours is set to' & @@ -1755,13 +1815,22 @@ subroutine ed_opspec_misc ifaterr = ifaterr +1 end if - if (include_fire < 0 .or. include_fire > 2) then + if (include_fire < 0 .or. include_fire > 3) then write (reason,fmt='(a,1x,i4,a)') & - 'Invalid INCLUDE_FIRE, it must be between 0 and 2. Yours is set to' & + 'Invalid INCLUDE_FIRE, it must be between 0 and 3. Yours is set to' & ,include_fire,'...' call opspec_fatal(reason,'opspec_misc') ifaterr = ifaterr +1 + else if (include_fire /= 0) then + if (fire_parameter < 0.0 .or. fire_parameter > 100.) then + write (reason,fmt='(a,1x,es12.5,a)') & + 'Invalid FIRE_PARAMETER, it must be between 0 and 100.. Yours is set to' & + , fire_parameter,'...' + call opspec_fatal(reason,'opspec_misc') + ifaterr = ifaterr +1 + end if end if + if (sm_fire < -3.1 .or. sm_fire > 1.) then write (reason,fmt='(a,1x,es12.5,a)') & @@ -2132,6 +2201,50 @@ subroutine ed_opspec_misc call opspec_fatal(reason,'opspec_misc') end if + + if (idetailed < 0 .or. idetailed > 63) then + write (reason,fmt='(a,1x,i4,a)') & + 'Invalid IDETAILED, it must be between 0 and 63. Yours is set to' & + ,idetailed,'...' + ifaterr = ifaterr +1 + call opspec_fatal(reason,'opspec_misc') + elseif (idetailed > 0) then + patch_detailed = ibclr(idetailed,5) > 0 + + if (patch_detailed .and. (n_poi > 1 .or. n_ed_region > 0)) then + write(unit=*,fmt='(a)') '--------------------------------------------------' + write(unit=*,fmt='(a,1x,i6)') ' IDETAILED = ',idetailed + write(unit=*,fmt='(a,1x,i6)') ' N_POI = ',n_poi + write(unit=*,fmt='(a,1x,i6)') ' N_ED_REGION = ',n_ed_region + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' The following should be all F in regional runs' + write(unit=*,fmt='(a)') ' or multiple polygon runs' + write(unit=*,fmt='(a,1x,l1)') ' - BUDGET [ 1] = ',btest(idetailed,0) + write(unit=*,fmt='(a,1x,l1)') ' - PHOTOSYNTHESIS [ 2] = ',btest(idetailed,1) + write(unit=*,fmt='(a,1x,l1)') ' - DETAILED INTEGRATOR [ 4] = ',btest(idetailed,2) + write(unit=*,fmt='(a,1x,l1)') ' - SANITY CHECK BOUNDS [ 8] = ',btest(idetailed,3) + write(unit=*,fmt='(a,1x,l1)') ' - ERROR RECORDING [16] = ',btest(idetailed,4) + write(unit=*,fmt='(a)') '--------------------------------------------------' + write (reason,fmt='(2(a,1x))') 'Only single polygon runs are allowed' & + ,'with detailed patch-level output...' + ifaterr = ifaterr +1 + call opspec_fatal(reason,'opspec_misc') + end if + + if (patch_keep < -2) then + write (reason,fmt='(a,2x,a,1x,i4,a)') & + 'Invalid PATCH_KEEP, it must be between -2 and number of patches.' & + ,'Yours is set to',patch_keep,'...' + ifaterr = ifaterr +1 + call opspec_fatal(reason,'opspec_misc') + end if + !------------------------------------------------------------------------------------! + end if + !---------------------------------------------------------------------------------------! + + + + !----- Stop the run if there are any fatal errors. -------------------------------------! if (ifaterr > 0) then write (unit=*,fmt='(a)') ' -----------ED_OPSPEC_MISC --------------------------' diff --git a/ED/src/io/ed_read_ed10_20_history.f90 b/ED/src/io/ed_read_ed10_20_history.f90 index 02dbdde41..f01bc5a65 100644 --- a/ED/src/io/ed_read_ed10_20_history.f90 +++ b/ED/src/io/ed_read_ed10_20_history.f90 @@ -50,7 +50,6 @@ subroutine read_ed10_ed20_history_file , area_indices ! ! subroutine use fuse_fiss_utils, only : sort_cohorts & ! subroutine , sort_patches ! ! subroutine - use disturb_coms , only : min_new_patch_area ! ! intent(in) implicit none !----- Local constants. ----------------------------------------------------------------! @@ -716,12 +715,12 @@ subroutine read_ed10_ed20_history_file - !----- Assign LAI, WPA, and WAI -----------------------------------! + !----- Assign LAI, WAI, and CAI -----------------------------------! call area_indices(cpatch%nplant(ic2),cpatch%bleaf(ic2) & ,cpatch%bdead(ic2),cpatch%balive(ic2) & ,cpatch%dbh(ic2), cpatch%hite(ic2) & ,cpatch%pft(ic2), SLA(cpatch%pft(ic2)) & - ,cpatch%lai(ic2),cpatch%wpa(ic2), cpatch%wai(ic2) & + ,cpatch%lai(ic2), cpatch%wai(ic2) & ,cpatch%crown_area(ic2),cpatch%bsapwood(ic2)) !----- Initialise the carbon balance. -----------------------------! @@ -774,17 +773,15 @@ subroutine read_ed10_ed20_history_file area_tot = sum(csite%area(1:csite%npatches)) csite%area(:) = csite%area(:)/area_tot - !----- Find the patch-level LAI, WPA, and WAI. --------------------------------! + !----- Find the patch-level LAI, WAI, and CAI. --------------------------------! do ipa=1,csite%npatches area_sum = area_sum + csite%area(ipa) csite%lai(ipa) = 0.0 - csite%wpa(ipa) = 0.0 csite%wai(ipa) = 0.0 cpatch => csite%patch(ipa) do ico = 1,cpatch%ncohorts csite%lai(ipa) = csite%lai(ipa) + cpatch%lai(ico) - csite%wpa(ipa) = csite%wpa(ipa) + cpatch%wpa(ico) csite%wai(ipa) = csite%wai(ipa) + cpatch%wai(ico) ncohorts = ncohorts + 1 end do @@ -823,7 +820,6 @@ subroutine read_ed10_ed20_history_file do ipa = 1,csite%npatches csite%lai(ipa) = 0.0 - csite%wpa(ipa) = 0.0 csite%wai(ipa) = 0.0 npatchco = 0 @@ -832,7 +828,6 @@ subroutine read_ed10_ed20_history_file ncohorts = ncohorts+1 npatchco = npatchco+1 csite%lai(ipa) = csite%lai(ipa) + cpatch%lai(ico) - csite%wpa(ipa) = csite%wpa(ipa) + cpatch%wpa(ico) csite%wai(ipa) = csite%wai(ipa) + cpatch%wai(ico) end do diff --git a/ED/src/io/ed_read_ed21_history.F90 b/ED/src/io/ed_read_ed21_history.F90 index ef8c9b750..7af64da5a 100644 --- a/ED/src/io/ed_read_ed21_history.F90 +++ b/ED/src/io/ed_read_ed21_history.F90 @@ -75,10 +75,12 @@ subroutine read_ed21_history_file integer, dimension(:) , allocatable :: sipa_id integer, dimension(:) , allocatable :: paco_n integer, dimension(:) , allocatable :: paco_id + integer, dimension(:) , allocatable :: islakesite integer :: year integer :: igr integer :: ipy integer :: isi + integer :: is integer :: ipa integer :: ico integer :: k @@ -96,6 +98,7 @@ subroutine read_ed21_history_file integer :: pa_index integer :: dsetrank integer :: iparallel + integer :: ndry_sites logical :: exists real, dimension(:) , allocatable :: file_lats real, dimension(:) , allocatable :: file_lons @@ -370,91 +373,31 @@ subroutine read_ed21_history_file - !----- Allocate the vector of sites in the polygon. ------------------------------! - call allocate_polygontype(cpoly,pysi_n(py_index)) - !---------------------------------------------------------------------------------! - - - - !----- Reset the HDF5 auxiliary variables before moving to the next level. -------! - globdims = 0_8 - chnkdims = 0_8 - chnkoffs = 0_8 - memoffs = 0_8 - memdims = 0_8 - memsize = 1_8 - !---------------------------------------------------------------------------------! - - - - !---------------------------------------------------------------------------------! - ! SITE level variables. ! - !---------------------------------------------------------------------------------! - !----- Load 1D dataset. ----------------------------------------------------------! - dsetrank = 1_8 + !----- Load the lakesite data-----------------------------------------------------! + allocate(islakesite(pysi_n(py_index))) + islakesite = 0 + dsetrank = 1_8 globdims(1) = int(dset_nsites_global,8) - chnkdims(1) = int(cpoly%nsites,8) + chnkdims(1) = int(pysi_n(py_index),8) chnkoffs(1) = int(pysi_id(py_index) - 1,8) - memdims(1) = int(cpoly%nsites,8) - memsize(1) = int(cpoly%nsites,8) - memoffs(1) = 0_8 - - call hdf_getslab_r(cpoly%area ,'AREA_SI ' ,dsetrank,iparallel,.true.) - call hdf_getslab_r(cpoly%moist_f ,'MOIST_F ' ,dsetrank,iparallel,.true.) - call hdf_getslab_r(cpoly%moist_W ,'MOIST_W ' ,dsetrank,iparallel,.true.) - call hdf_getslab_r(cpoly%elevation ,'ELEVATION ' ,dsetrank,iparallel,.true.) - call hdf_getslab_r(cpoly%slope ,'SLOPE ' ,dsetrank,iparallel,.true.) - call hdf_getslab_r(cpoly%aspect ,'ASPECT ' ,dsetrank,iparallel,.true.) - call hdf_getslab_r(cpoly%TCI ,'TCI ' ,dsetrank,iparallel,.true.) - call hdf_getslab_i(cpoly%patch_count,'PATCH_COUNT ' ,dsetrank,iparallel,.true.) - call hdf_getslab_i(cpoly%ncol_soil ,'NCOL_SOIL_SI ',dsetrank,iparallel,.true.) + memdims(1) = int(pysi_n(py_index),8) + memsize(1) = int(pysi_n(py_index),8) + memoffs(1) = 0_8 + call hdf_getslab_i(islakesite,'ISLAKESITE ',dsetrank,iparallel,.false.) - !----- Load 2D dataset. ----------------------------------------------------------! - dsetrank = 2_8 - globdims(1) = int(dset_nzg,8) ! How many layers in the dataset? - chnkdims(1) = int(1,8) ! We are only extracting one layer - memdims(1) = int(1,8) ! We only need memory for one layer - memsize(1) = int(1,8) ! On both sides - chnkoffs(1) = int(dset_nzg - 1,8) ! Take the top layer, not the bottom - memoffs(1) = 0_8 - globdims(2) = int(dset_nsites_global,8) - chnkdims(2) = int(cpoly%nsites,8) - chnkoffs(2) = int(pysi_id(py_index) - 1,8) - memdims(2) = int(cpoly%nsites,8) - memsize(2) = int(cpoly%nsites,8) - memoffs(2) = 0_8 - call hdf_getslab_i(cpoly%ntext_soil(nzg,:),'NTEXT_SOIL_SI ',dsetrank & - ,iparallel,.true.) - do isi=1,cpoly%nsites - - !------------------------------------------------------------------------------! - ! The soil layer in this case is use defined, so take this from the ! - ! grid level variable, and not from the dataset. ! - !------------------------------------------------------------------------------! - cpoly%lsl(isi) = cgrid%lsl(ipy) ! Initialize lowest soil layer - - !----- Now fill the soil column based on the top layer data. ------------------! - do k=1,nzg-1 - cpoly%ntext_soil(k,isi) = cpoly%ntext_soil(nzg,isi) - end do - end do + ndry_sites = int(pysi_n(py_index))-sum(islakesite) !---------------------------------------------------------------------------------! - - !---------------------------------------------------------------------------------! - ! Loop over all sites and fill the patch-level variables. ! + !----- Allocate the vector of sites in the polygon. ------------------------------! + call allocate_polygontype(cpoly,ndry_sites) !---------------------------------------------------------------------------------! - siteloop: do isi = 1,cpoly%nsites - csite => cpoly%site(isi) - - !----- Calculate the index of this site data in the HDF5 file. ----------------! - si_index = pysi_id(py_index) + isi - 1 - if (sipa_n(si_index) > 0) then + is = 0 + siteloop: do isi=1,pysi_n(py_index) - !----- Fill 1D polygon (site unique) level variables. ----------------------! - call allocate_sitetype(csite,sipa_n(si_index)) + if (islakesite(isi) == 0) then + is=is+1 !----- Reset the HDF5 auxiliary variables before moving to the next level. -! globdims = 0_8 @@ -465,46 +408,79 @@ subroutine read_ed21_history_file memsize = 1_8 !---------------------------------------------------------------------------! - iparallel = 0 - - dsetrank = 1 - globdims(1) = int(dset_npatches_global,8) - chnkdims(1) = int(csite%npatches,8) - chnkoffs(1) = int(sipa_id(si_index) - 1,8) - memdims(1) = int(csite%npatches,8) - memsize(1) = int(csite%npatches,8) - memoffs(1) = 0 - - call hdf_getslab_i(csite%dist_type ,'DIST_TYPE ' ,dsetrank,iparallel,.true.) - call hdf_getslab_r(csite%age ,'AGE ' ,dsetrank,iparallel,.true.) - call hdf_getslab_r(csite%area ,'AREA ' ,dsetrank,iparallel,.true.) - call hdf_getslab_r(csite%sum_dgd ,'SUM_DGD ' ,dsetrank,iparallel,.true.) - call hdf_getslab_r(csite%sum_chd ,'SUM_CHD ' ,dsetrank,iparallel,.true.) - call hdf_getslab_i(csite%plantation,'PLANTATION ',dsetrank,iparallel,.true.) - - call hdf_getslab_r(csite%fast_soil_C ,'FAST_SOIL_C ' & - ,dsetrank,iparallel,.true.) - call hdf_getslab_r(csite%slow_soil_C ,'SLOW_SOIL_C ' & - ,dsetrank,iparallel,.true.) - call hdf_getslab_r(csite%fast_soil_N ,'FAST_SOIL_N ' & - ,dsetrank,iparallel,.true.) - call hdf_getslab_r(csite%structural_soil_C ,'STRUCTURAL_SOIL_C ' & - ,dsetrank,iparallel,.true.) - call hdf_getslab_r(csite%structural_soil_L ,'STRUCTURAL_SOIL_L ' & - ,dsetrank,iparallel,.true.) - call hdf_getslab_r(csite%mineralized_soil_N,'MINERALIZED_SOIL_N ' & + + + !---------------------------------------------------------------------------! + ! SITE level variables. ! + !---------------------------------------------------------------------------! + !----- Load 1D dataset. ----------------------------------------------------! + dsetrank = 1_8 + globdims(1) = int(dset_nsites_global,8) + chnkdims(1) = int(1,8) + chnkoffs(1) = int(pysi_id(py_index) - 2 + isi,8) + memdims(1) = int(1,8) + memsize(1) = int(1,8) + memoffs(1) = 0_8 + + call hdf_getslab_r( cpoly%area (is:is), 'AREA_SI ' & + , dsetrank, iparallel, .true.) + call hdf_getslab_r( cpoly%moist_f (is:is), 'MOIST_F ' & + , dsetrank, iparallel, .true.) + call hdf_getslab_r( cpoly%moist_W (is:is), 'MOIST_W ' & + , dsetrank, iparallel, .true.) + call hdf_getslab_r( cpoly%elevation (is:is), 'ELEVATION ' & + , dsetrank, iparallel, .true.) + call hdf_getslab_r( cpoly%slope (is:is), 'SLOPE ' & + , dsetrank, iparallel, .true.) + call hdf_getslab_r( cpoly%aspect (is:is), 'ASPECT ' & + , dsetrank, iparallel, .true.) + call hdf_getslab_r( cpoly%TCI (is:is), 'TCI ' & + , dsetrank, iparallel, .true.) + call hdf_getslab_i( cpoly%patch_count(is:is), 'PATCH_COUNT ' & + , dsetrank, iparallel, .true.) + call hdf_getslab_i( cpoly%ncol_soil (is:is), 'NCOL_SOIL_SI ' & + , dsetrank, iparallel, .true.) + + !----- Load 2D dataset. ----------------------------------------------------! + dsetrank = 2_8 + globdims(1) = int(dset_nzg,8) ! How many layers in the dataset? + chnkdims(1) = int(1,8) ! We are only extracting one layer + memdims(1) = int(1,8) ! We only need memory for one layer + memsize(1) = int(1,8) ! On both sides + chnkoffs(1) = int(dset_nzg - 1,8) ! Take the top layer, not the bottom + memoffs(1) = 0_8 + + globdims(2) = int(dset_nsites_global,8) + chnkdims(2) = int(1,8) + chnkoffs(2) = int(pysi_id(py_index) - 2 + isi,8) + memdims(2) = int(1,8) + memsize(2) = int(1,8) + memoffs(2) = 0_8 + call hdf_getslab_i(cpoly%ntext_soil(nzg:nzg,is:is),'NTEXT_SOIL_SI ' & ,dsetrank,iparallel,.true.) + + !---------------------------------------------------------------------------! - ! Loop over all sites and fill the patch-level variables. ! + ! The soil layer in this case is use defined, so take this from the ! + ! grid level variable, and not from the dataset. ! !---------------------------------------------------------------------------! - patchloop: do ipa = 1,csite%npatches + cpoly%lsl(is) = cgrid%lsl(ipy) ! Initialize lowest soil layer - !------------------------------------------------------------------------! - ! Reset the HDF5 auxiliary variables before moving to the next ! - ! level. ! - !------------------------------------------------------------------------! + !----- Now fill the soil column based on the top layer data. ---------------! + do k=1,nzg-1 + cpoly%ntext_soil(k,is) = cpoly%ntext_soil(nzg,is) + end do + + csite => cpoly%site(isi) + + if (sipa_n(si_index) > 0) then + + !----- Fill 1D polygon (site unique) level variables. -------------------! + call allocate_sitetype(csite,sipa_n(si_index)) + + !----- Reset the HDF5 auxiliary variables before moving to the next level. -! globdims = 0_8 chnkdims = 0_8 chnkoffs = 0_8 @@ -513,223 +489,291 @@ subroutine read_ed21_history_file memsize = 1_8 !------------------------------------------------------------------------! - cpatch => csite%patch(ipa) + iparallel = 0 + + dsetrank = 1 + globdims(1) = int(dset_npatches_global,8) + chnkdims(1) = int(csite%npatches,8) + chnkoffs(1) = int(sipa_id(si_index) - 1,8) + memdims(1) = int(csite%npatches,8) + memsize(1) = int(csite%npatches,8) + memoffs(1) = 0 - !----- Initialise patch-level variables that depend on the cohort ones. -! - csite%lai(ipa) = 0.0 - csite%wpa(ipa) = 0.0 - csite%wai(ipa) = 0.0 - csite%plant_ag_biomass(ipa) = 0.0 + call hdf_getslab_i(csite%dist_type ,'DIST_TYPE ' & + ,dsetrank,iparallel,.true.) + call hdf_getslab_r(csite%age ,'AGE ' & + ,dsetrank,iparallel,.true.) + call hdf_getslab_r(csite%area ,'AREA ' & + ,dsetrank,iparallel,.true.) + call hdf_getslab_r(csite%sum_dgd ,'SUM_DGD ' & + ,dsetrank,iparallel,.true.) + call hdf_getslab_r(csite%sum_chd ,'SUM_CHD ' & + ,dsetrank,iparallel,.true.) + call hdf_getslab_i(csite%plantation,'PLANTATION ' & + ,dsetrank,iparallel,.true.) + + call hdf_getslab_r(csite%fast_soil_C ,'FAST_SOIL_C ' & + ,dsetrank,iparallel,.true.) + call hdf_getslab_r(csite%slow_soil_C ,'SLOW_SOIL_C ' & + ,dsetrank,iparallel,.true.) + call hdf_getslab_r(csite%fast_soil_N ,'FAST_SOIL_N ' & + ,dsetrank,iparallel,.true.) + call hdf_getslab_r(csite%structural_soil_C ,'STRUCTURAL_SOIL_C ' & + ,dsetrank,iparallel,.true.) + call hdf_getslab_r(csite%structural_soil_L ,'STRUCTURAL_SOIL_L ' & + ,dsetrank,iparallel,.true.) + call hdf_getslab_r(csite%mineralized_soil_N,'MINERALIZED_SOIL_N ' & + ,dsetrank,iparallel,.true.) - pa_index = sipa_id(si_index) + ipa - 1 - call allocate_patchtype(cpatch,paco_n(pa_index)) !------------------------------------------------------------------------! - ! Empty patches may exist, so make sure that this part is called ! - ! only when there are cohorts. ! + ! Loop over all sites and fill the patch-level variables. ! !------------------------------------------------------------------------! - if (cpatch%ncohorts > 0) then - !----- First the 1-D variables. --------------------------------------! - dsetrank = 1 - globdims(1) = int(dset_ncohorts_global,8) - chnkdims(1) = int(cpatch%ncohorts,8) - chnkoffs(1) = int(paco_id(pa_index) - 1,8) - memdims(1) = int(cpatch%ncohorts,8) - memsize(1) = int(cpatch%ncohorts,8) - memoffs(1) = 0_8 - - call hdf_getslab_r(cpatch%dbh ,'DBH ' ,dsetrank,iparallel,.true.) - call hdf_getslab_r(cpatch%bdead ,'BDEAD ' ,dsetrank,iparallel,.true.) - call hdf_getslab_i(cpatch%pft ,'PFT ' ,dsetrank,iparallel,.true.) - call hdf_getslab_r(cpatch%nplant,'NPLANT ',dsetrank,iparallel,.true.) + patchloop: do ipa = 1,csite%npatches !---------------------------------------------------------------------! - ! Find derived properties from Bdead. In the unlikely case that ! - ! bdead is zero, then we use DBH as the starting point. In both ! - ! cases we assume that plants are in allometry. ! + ! Reset the HDF5 auxiliary variables before moving to the next ! + ! level. ! + !---------------------------------------------------------------------! + globdims = 0_8 + chnkdims = 0_8 + chnkoffs = 0_8 + memoffs = 0_8 + memdims = 0_8 + memsize = 1_8 !---------------------------------------------------------------------! - do ico=1,cpatch%ncohorts - ipft = cpatch%pft(ico) - - if (cpatch%bdead(ico) > 0.0) then - cpatch%bdead(ico) = max(cpatch%bdead(ico),min_bdead(ipft)) - cpatch%dbh(ico) = bd2dbh(cpatch%pft(ico),cpatch%bdead(ico)) - cpatch%hite(ico) = dbh2h (cpatch%pft(ico),cpatch%dbh (ico)) - else - cpatch%dbh(ico) = max(cpatch%dbh(ico),min_dbh(ipft)) - cpatch%hite(ico) = dbh2h (cpatch%pft(ico),cpatch%dbh (ico)) - cpatch%bdead(ico) = dbh2bd(cpatch%dbh(ico),cpatch%pft (ico)) - end if - - cpatch%bleaf(ico) = dbh2bl(cpatch%dbh(ico),cpatch%pft(ico)) - - !----- Find the other pools. --------------------------------------! - salloc = (1.0 + q(ipft) + qsw(ipft) * cpatch%hite(ico)) - salloci = 1.0 / salloc - cpatch%balive (ico) = cpatch%bleaf(ico) * salloc - cpatch%broot (ico) = cpatch%balive(ico) * q(ipft) * salloci - cpatch%bsapwood(ico) = cpatch%balive(ico) * qsw(ipft) & - * cpatch%hite(ico) * salloci - cpatch%bstorage(ico) = 0.0 - cpatch%phenology_status(ico) = 0 - end do - !----- Then the 2-D variables. ---------------------------------------! - dsetrank = 2 - globdims(1) = 13_8 - chnkdims(1) = 13_8 - chnkoffs(1) = 0_8 - memdims(1) = 13_8 - memsize(1) = 13_8 - memoffs(2) = 0_8 - globdims(2) = int(dset_ncohorts_global,8) - chnkdims(2) = int(cpatch%ncohorts,8) - chnkoffs(2) = int(paco_id(pa_index) - 1,8) - memdims(2) = int(cpatch%ncohorts,8) - memsize(2) = int(cpatch%ncohorts,8) - memoffs(2) = 0_8 - - call hdf_getslab_r(cpatch%cb ,'CB ' ,dsetrank,iparallel,.true.) - call hdf_getslab_r(cpatch%cb_max,'CB_MAX ',dsetrank,iparallel,.true.) - - !----- The following variables are initialised with default values. --! - cpatch%dagb_dt = 0. - cpatch%dba_dt = 0. - cpatch%ddbh_dt = 0. - cpatch%fsw = 1.0 - cpatch%gpp = 0.0 - cpatch%par_l = 0.0 - - cohortloop: do ico=1,cpatch%ncohorts + cpatch => csite%patch(ipa) + + !---------------------------------------------------------------------! + ! Initialise patch-level variables that depend on the cohort ones. ! + !---------------------------------------------------------------------! + csite%lai(ipa) = 0.0 + csite%wai(ipa) = 0.0 + csite%plant_ag_biomass(ipa) = 0.0 + + pa_index = sipa_id(si_index) + ipa - 1 + call allocate_patchtype(cpatch,paco_n(pa_index)) + + !---------------------------------------------------------------------! + ! Empty patches may exist, so make sure that this part is called ! + ! only when there are cohorts. ! + !---------------------------------------------------------------------! + if (cpatch%ncohorts > 0) then + !----- First the 1-D variables. -----------------------------------! + dsetrank = 1 + globdims(1) = int(dset_ncohorts_global,8) + chnkdims(1) = int(cpatch%ncohorts,8) + chnkoffs(1) = int(paco_id(pa_index) - 1,8) + memdims(1) = int(cpatch%ncohorts,8) + memsize(1) = int(cpatch%ncohorts,8) + memoffs(1) = 0_8 + + call hdf_getslab_r(cpatch%dbh ,'DBH ' & + ,dsetrank,iparallel,.true.) + call hdf_getslab_r(cpatch%bdead ,'BDEAD ' & + ,dsetrank,iparallel,.true.) + call hdf_getslab_i(cpatch%pft ,'PFT ' & + ,dsetrank,iparallel,.true.) + call hdf_getslab_r(cpatch%nplant,'NPLANT ' & + ,dsetrank,iparallel,.true.) + !------------------------------------------------------------------! - ! We will now check the PFT of each cohort, so we determine ! - ! if this is a valid PFT. If not, then we must decide what we ! - ! should do... ! + ! Find derived properties from Bdead. In the unlikely case ! + ! that bdead is zero, then we use DBH as the starting point. In ! + ! both cases we assume that plants are in allometry. ! !------------------------------------------------------------------! - if (.not. include_pft(cpatch%pft(ico))) then - select case(pft_1st_check) - case (0) - !----- Stop the run. ----------------------------------------! - write (unit=*,fmt='(a,1x,i5,1x,a)') & - 'I found a cohort with PFT=',cpatch%pft(ico) & - ,' and it is not in your include_these_pft...' - call fatal_error('Invalid PFT in history file' & - ,'read_ed21_history_file' & - ,'ed_read_ed21_history.F90') - - case (1) - !----- Include the unexpected PFT in the list. --------------! - write (unit=*,fmt='(a,1x,i5,1x,a)') & - 'I found a cohort with PFT=',cpatch%pft(ico) & - ,'... Including this PFT in your include_these_pft...' - include_pft(cpatch%pft(ico)) = .true. - include_these_pft(count(include_pft)) = cpatch%pft(ico) - - call sort_up(include_these_pft,n_pft) - - if (is_grass(cpatch%pft(ico))) then - include_pft_ag(cpatch%pft(ico)) = .true. - end if - - case (2) - !----- Ignore the unexpect PFT. -----------------------------! - write (unit=*,fmt='(a,1x,i5,1x,a)') & - 'I found a cohort with PFT=',cpatch%pft(ico) & - ,'... Ignoring it...' - !------------------------------------------------------------! - ! The way we will ignore this cohort is by setting its ! - ! nplant to zero, and calling the "terminate_cohorts" ! - ! subroutine right after this. ! - !------------------------------------------------------------! - cpatch%nplant(ico) = 0. - end select - end if + do ico=1,cpatch%ncohorts + ipft = cpatch%pft(ico) + if (cpatch%bdead(ico) > 0.0) then + cpatch%bdead(ico) = max(cpatch%bdead(ico),min_bdead(ipft)) + cpatch%dbh(ico) = bd2dbh(cpatch%pft(ico),cpatch%bdead(ico)) + cpatch%hite(ico) = dbh2h (cpatch%pft(ico),cpatch%dbh (ico)) + else + cpatch%dbh(ico) = max(cpatch%dbh(ico),min_dbh(ipft)) + cpatch%hite(ico) = dbh2h (cpatch%pft(ico),cpatch%dbh (ico)) + cpatch%bdead(ico) = dbh2bd(cpatch%dbh(ico),cpatch%pft (ico)) + end if + + cpatch%bleaf(ico) = dbh2bl(cpatch%dbh(ico),cpatch%pft(ico)) + + !----- Find the other pools. -----------------------------------! + salloc = (1.0 + q(ipft) + qsw(ipft) * cpatch%hite(ico)) + salloci = 1.0 / salloc + cpatch%balive (ico) = cpatch%bleaf(ico) * salloc + cpatch%broot (ico) = cpatch%balive(ico) * q(ipft) * salloci + cpatch%bsapwood(ico) = cpatch%balive(ico) * qsw(ipft) & + * cpatch%hite(ico) * salloci + cpatch%bstorage(ico) = 0.0 + cpatch%phenology_status(ico) = 0 + end do + + !----- Then the 2-D variables. ------------------------------------! + dsetrank = 2 + globdims(1) = 13_8 + chnkdims(1) = 13_8 + chnkoffs(1) = 0_8 + memdims(1) = 13_8 + memsize(1) = 13_8 + memoffs(2) = 0_8 + globdims(2) = int(dset_ncohorts_global,8) + chnkdims(2) = int(cpatch%ncohorts,8) + chnkoffs(2) = int(paco_id(pa_index) - 1,8) + memdims(2) = int(cpatch%ncohorts,8) + memsize(2) = int(cpatch%ncohorts,8) + memoffs(2) = 0_8 + + call hdf_getslab_r(cpatch%cb ,'CB ' & + ,dsetrank,iparallel,.true.) + call hdf_getslab_r(cpatch%cb_max,'CB_MAX ' & + ,dsetrank,iparallel,.true.) + !------------------------------------------------------------------! - ! Make sure that the biomass won't lead to FPE. This ! - ! should never happen when using a stable ED-2.1 version, but ! - ! older versions had "zombie" cohorts. Here we ensure that ! - ! the model initialises with stable numbers whilst ensuring ! - ! that the cohorts will be eliminated. ! - !------------------------------------------------------------------! - if (cpatch%balive(ico) > 0. .and. & - cpatch%balive(ico) < tiny_biomass) then - cpatch%balive(ico) = tiny_biomass - end if - if (cpatch%bleaf(ico) > 0. .and. & - cpatch%bleaf(ico) < tiny_biomass) then - cpatch%bleaf(ico) = tiny_biomass - end if - if (cpatch%broot(ico) > 0. .and. & - cpatch%broot(ico) < tiny_biomass) then - cpatch%broot(ico) = tiny_biomass - end if - if (cpatch%bsapwood(ico) > 0. .and. & - cpatch%bsapwood(ico) < tiny_biomass) then - cpatch%bsapwood(ico) = tiny_biomass - end if - if (cpatch%bdead(ico) > 0. .and. & - cpatch%bdead(ico) < tiny_biomass) then - cpatch%bdead(ico) = tiny_biomass - end if - if (cpatch%bstorage(ico) > 0. .and. & - cpatch%bstorage(ico) < tiny_biomass) then - cpatch%bstorage(ico) = tiny_biomass - end if + ! The following variables are initialised with default values. ! !------------------------------------------------------------------! + cpatch%dagb_dt = 0. + cpatch%dba_dt = 0. + cpatch%ddbh_dt = 0. + cpatch%fsw = 1.0 + cpatch%gpp = 0.0 + cpatch%par_l = 0.0 + + cohortloop: do ico=1,cpatch%ncohorts + !---------------------------------------------------------------! + ! We will now check the PFT of each cohort, so we determine ! + ! if this is a valid PFT. If not, then we must decide what we ! + ! should do... ! + !---------------------------------------------------------------! + if (.not. include_pft(cpatch%pft(ico))) then + select case(pft_1st_check) + case (0) + !----- Stop the run. -------------------------------------! + write (unit=*,fmt='(a,1x,i5,1x,a)') & + 'I found a cohort with PFT=',cpatch%pft(ico) & + ,' and it is not in your include_these_pft...' + call fatal_error('Invalid PFT in history file' & + ,'read_ed21_history_file' & + ,'ed_read_ed21_history.F90') + case (1) + !----- Include the unexpected PFT in the list. -----------! + write (unit=*,fmt='(a,1x,i5,1x,a)') & + 'I found a cohort with PFT=',cpatch%pft(ico) & + ,'... Including this PFT in your include_these_pft...' + include_pft(cpatch%pft(ico)) = .true. + include_these_pft(count(include_pft)) = cpatch%pft(ico) + call sort_up(include_these_pft,n_pft) + if (is_grass(cpatch%pft(ico))) then + include_pft_ag(cpatch%pft(ico)) = .true. + end if - !----- Compute the above-ground biomass. --------------------------! - cpatch%agb(ico) = ed_biomass(cpatch%bdead(ico),cpatch%balive(ico) & - ,cpatch%bleaf(ico),cpatch%pft(ico) & - ,cpatch%hite(ico),cpatch%bstorage(ico) & - ,cpatch%bsapwood(ico)) + case (2) + !----- Ignore the unexpect PFT. --------------------------! + write (unit=*,fmt='(a,1x,i5,1x,a)') & + 'I found a cohort with PFT=',cpatch%pft(ico) & + ,'... Ignoring it...' + !---------------------------------------------------------! + ! The way we will ignore this cohort is by setting its ! + ! nplant to zero, and calling the "terminate_cohorts" ! + ! subroutine right after this. ! + !---------------------------------------------------------! + cpatch%nplant(ico) = 0. + end select + end if - cpatch%basarea(ico) = pio4 * cpatch%dbh(ico) * cpatch%dbh(ico) + !---------------------------------------------------------------! + ! Make sure that the biomass won't lead to FPE. This ! + ! should never happen when using a stable ED-2.1 version, but ! + ! older versions had "zombie" cohorts. Here we ensure that ! + ! the model initialises with stable numbers whilst ensuring ! + ! that the cohorts will be eliminated. ! + !---------------------------------------------------------------! + if (cpatch%balive(ico) > 0. .and. & + cpatch%balive(ico) < tiny_biomass) then + cpatch%balive(ico) = tiny_biomass + end if + if (cpatch%bleaf(ico) > 0. .and. & + cpatch%bleaf(ico) < tiny_biomass) then + cpatch%bleaf(ico) = tiny_biomass + end if + if (cpatch%broot(ico) > 0. .and. & + cpatch%broot(ico) < tiny_biomass) then + cpatch%broot(ico) = tiny_biomass + end if + if (cpatch%bsapwood(ico) > 0. .and. & + cpatch%bsapwood(ico) < tiny_biomass) then + cpatch%bsapwood(ico) = tiny_biomass + end if + if (cpatch%bdead(ico) > 0. .and. & + cpatch%bdead(ico) < tiny_biomass) then + cpatch%bdead(ico) = tiny_biomass + end if + if (cpatch%bstorage(ico) > 0. .and. & + cpatch%bstorage(ico) < tiny_biomass) then + cpatch%bstorage(ico) = tiny_biomass + end if + !---------------------------------------------------------------! - - !----- Assign LAI, WPA, and WAI -----------------------------------! - call area_indices(cpatch%nplant(ico),cpatch%bleaf(ico) & - ,cpatch%bdead(ico),cpatch%balive(ico) & - ,cpatch%dbh(ico), cpatch%hite(ico) & - ,cpatch%pft(ico), SLA(cpatch%pft(ico)) & - ,cpatch%lai(ico),cpatch%wpa(ico), cpatch%wai(ico) & - ,cpatch%crown_area(ico),cpatch%bsapwood(ico)) - !----- Update the derived patch-level variables. ------------------! - csite%lai(ipa) = csite%lai(ipa) + cpatch%lai(ico) - csite%wpa(ipa) = csite%wpa(ipa) + cpatch%wpa(ico) - csite%wai(ipa) = csite%wai(ipa) + cpatch%wai(ico) - csite%plant_ag_biomass(ipa) = csite%plant_ag_biomass(ipa) & - + cpatch%agb(ico)*cpatch%nplant(ico) - !----- Initialise the other cohort level variables. ---------------! - call init_ed_cohort_vars(cpatch,ico,cpoly%lsl(isi)) - end do cohortloop + !----- Compute the above-ground biomass. -----------------------! + cpatch%agb(ico) = ed_biomass(cpatch%bdead(ico) & + ,cpatch%balive(ico) & + ,cpatch%bleaf(ico) & + ,cpatch%pft(ico) & + ,cpatch%hite(ico) & + ,cpatch%bstorage(ico) & + ,cpatch%bsapwood(ico) ) - !---------------------------------------------------------------------! - ! Eliminate any "unwanted" cohort (i.e., those which nplant was ! - ! set to zero so it would be removed). ! - !---------------------------------------------------------------------! - call terminate_cohorts(csite,ipa,elim_nplant,elim_lai) + cpatch%basarea(ico) = pio4 * cpatch%dbh(ico) * cpatch%dbh(ico) - end if - end do patchloop - else - !----- This should never happen, but, just in case... ----------------------! - call fatal_error('A site with no patches was found...' & - ,'read_ed21_history_file','ed_read_ed21_history.F90') - end if + + !----- Assign LAI, WAI, and CAI --------------------------------! + call area_indices(cpatch%nplant(ico),cpatch%bleaf(ico) & + ,cpatch%bdead(ico),cpatch%balive(ico) & + ,cpatch%dbh(ico), cpatch%hite(ico) & + ,cpatch%pft(ico), SLA(cpatch%pft(ico)) & + ,cpatch%lai(ico),cpatch%wai(ico) & + ,cpatch%crown_area(ico),cpatch%bsapwood(ico)) - !----- Initialise the other patch-level variables. ----------------------------! - call init_ed_patch_vars(csite,1,csite%npatches,cpoly%lsl(isi)) - end do siteloop + !----- Update the derived patch-level variables. ---------------! + csite%lai(ipa) = csite%lai(ipa) + cpatch%lai(ico) + csite%wai(ipa) = csite%wai(ipa) + cpatch%wai(ico) + csite%plant_ag_biomass(ipa) = csite%plant_ag_biomass(ipa) & + + cpatch%agb(ico)*cpatch%nplant(ico) + !----- Initialise the other cohort level variables. ------------! + call init_ed_cohort_vars(cpatch,ico,cpoly%lsl(isi)) + end do cohortloop + !------------------------------------------------------------------! + ! Eliminate any "unwanted" cohort (i.e., those which nplant was ! + ! set to zero so it would be removed). ! + !------------------------------------------------------------------! + call terminate_cohorts(csite,ipa,elim_nplant,elim_lai) + + end if + end do patchloop + else + !----- This should never happen, but, just in case... -------------------! + call fatal_error('A site with no patches was found...' & + ,'read_ed21_history_file','ed_read_ed21_history.F90') + end if + + !----- Initialise the other patch-level variables. -------------------------! + call init_ed_patch_vars(csite,1,csite%npatches,cpoly%lsl(isi)) + + end if + !------------------------------------------------------------------------------! + end do siteloop + !---------------------------------------------------------------------------------! + + deallocate(islakesite) !----- Initialise some site-level variables. -------------------------------------! call init_ed_site_vars(cpoly,cgrid%lat(ipy)) @@ -753,10 +797,14 @@ subroutine read_ed21_history_file end if !------ Deallocate the temporary vectors, so no memory leak happens. ----------------! - deallocate(file_lats,file_lons) - deallocate(paco_n,paco_id) - deallocate(sipa_n,sipa_id) - deallocate(pysi_n,pysi_id ) + deallocate(file_lats) + deallocate(file_lons) + deallocate(paco_n ) + deallocate(paco_id ) + deallocate(sipa_n ) + deallocate(sipa_id ) + deallocate(pysi_n ) + deallocate(pysi_id ) end do gridloop @@ -824,11 +872,9 @@ subroutine read_ed21_history_unstruct , sitetype & ! variable type , patchtype & ! variable type , edtype & ! variable type - , edgrid_g & ! variable type - , allocate_polygontype & ! subroutine + , edgrid_g & ! subroutine , allocate_sitetype & ! subroutine - , allocate_patchtype & ! subroutine - , deallocate_polygontype ! ! subroutine + , allocate_patchtype ! ! subroutine use grid_coms , only : ngrids & ! intent(in) , nzg ! ! intent(in) use consts_coms , only : pio4 ! ! intent(in) @@ -851,7 +897,7 @@ subroutine read_ed21_history_unstruct use fuse_fiss_utils, only : terminate_cohorts ! ! subroutine use disturb_coms , only : ianth_disturb & ! intent(in) , lu_rescale_file & ! intent(in) - , min_new_patch_area ! ! intent(in) + , min_patch_area ! ! intent(in) use soil_coms , only : soil ! ! intent(in) implicit none @@ -860,7 +906,6 @@ subroutine read_ed21_history_unstruct !----- Local variables. ----------------------------------------------------------------! type(edtype) , pointer :: cgrid type(polygontype) , pointer :: cpoly - type(polygontype) , pointer :: tpoly type(sitetype) , pointer :: csite type(patchtype) , pointer :: cpatch character(len=str_len), dimension(maxlist) :: full_list @@ -880,14 +925,28 @@ subroutine read_ed21_history_unstruct integer , dimension( :) , allocatable :: paco_n integer , dimension( :) , allocatable :: paco_id integer , dimension(:,:) , allocatable :: this_ntext + integer , dimension( :) , allocatable :: islakesite + real , dimension( :) , allocatable :: tpoly_area + real , dimension( :) , allocatable :: tpoly_moist_f + real , dimension( :) , allocatable :: tpoly_moist_w + real , dimension( :) , allocatable :: tpoly_elevation + real , dimension( :) , allocatable :: tpoly_slope + real , dimension( :) , allocatable :: tpoly_aspect + real , dimension( :) , allocatable :: tpoly_TCI + integer , dimension( :) , allocatable :: tpoly_patch_count + integer , dimension( :) , allocatable :: tpoly_lsl + integer , dimension(:,:) , allocatable :: tpoly_ntext_soil integer :: year integer :: igr integer :: ipy integer :: isi + integer :: is integer :: ipa integer :: ico integer :: isi_best + integer :: is_best integer :: isi_try + integer :: is_try integer :: nsoil integer :: nsoil_try integer :: nsites_inp @@ -917,6 +976,7 @@ subroutine read_ed21_history_unstruct integer :: total_grid_py integer :: poi_minloc integer :: ngp1 + integer :: ndry_sites logical :: exists logical :: rescale_glob logical :: rescale_loc @@ -1333,87 +1393,143 @@ subroutine read_ed21_history_unstruct - !------------------------------------------------------------------------------! - ! Site level. Here we allocate a temporary site that will grab the ! - ! soil type information. We then copy the data with the closest soil texture ! - ! properties to the definite site, preserving the previously assigned area. ! + ! Check whether the input data had lakes or not. ! !------------------------------------------------------------------------------! - nsites_inp = pysi_n(py_index) - nullify (tpoly) - allocate (tpoly) - allocate (this_ntext(dset_nzg,nsites_inp)) - call allocate_polygontype(tpoly,nsites_inp) + allocate(islakesite(pysi_n(py_index))) + islakesite = 0 + !----- Load the lakesite data--------------------------------------------------! + dsetrank = 1_8 + globdims(1) = int(dset_nsites_global,8) + chnkdims(1) = int(pysi_n(py_index),8) + chnkoffs(1) = int(pysi_id(py_index) - 1,8) + memdims(1) = int(pysi_n(py_index),8) + memsize(1) = int(pysi_n(py_index),8) + memoffs(1) = 0_8 + call hdf_getslab_i(islakesite,'ISLAKESITE ',dsetrank,iparallel,.false.) + ndry_sites = int(pysi_n(py_index))-sum(islakesite) !------------------------------------------------------------------------------! - !----- Reset the HDF5 auxiliary variables before moving to the next level. ----! - globdims = 0_8 - chnkdims = 0_8 - chnkoffs = 0_8 - memoffs = 0_8 - memdims = 0_8 - memsize = 1_8 - !------------------------------------------------------------------------------! - ! SITE level variables. ! + ! Site level. Here we allocate temporary site variables that will grab ! + ! the soil type information. We then copy the data with the closest soil ! + ! texture properties to the definite site, preserving the previously assigned ! + ! area. ! + !------------------------------------------------------------------------------! + nsites_inp = ndry_sites + allocate (this_ntext (dset_nzg,nsites_inp)) + allocate (tpoly_area ( nsites_inp)) + allocate (tpoly_moist_f ( nsites_inp)) + allocate (tpoly_moist_w ( nsites_inp)) + allocate (tpoly_elevation ( nsites_inp)) + allocate (tpoly_slope ( nsites_inp)) + allocate (tpoly_aspect ( nsites_inp)) + allocate (tpoly_TCI ( nsites_inp)) + allocate (tpoly_patch_count ( nsites_inp)) + allocate (tpoly_lsl ( nsites_inp)) + allocate (tpoly_ntext_soil ( nzg,nsites_inp)) !------------------------------------------------------------------------------! - !----- Load 1D dataset. -------------------------------------------------------! - dsetrank = 1_8 - globdims(1) = int(dset_nsites_global,8) - chnkdims(1) = int(tpoly%nsites,8) - chnkoffs(1) = int(pysi_id(py_index) - 1,8) - memdims(1) = int(tpoly%nsites,8) - memsize(1) = int(tpoly%nsites,8) - memoffs(1) = 0_8 - call hdf_getslab_r(tpoly%area ,'AREA_SI ' ,dsetrank,iparallel,.true.) - call hdf_getslab_r(tpoly%moist_f ,'MOIST_F ' ,dsetrank,iparallel,.true.) - call hdf_getslab_r(tpoly%moist_W ,'MOIST_W ' ,dsetrank,iparallel,.true.) - call hdf_getslab_r(tpoly%elevation ,'ELEVATION ' ,dsetrank,iparallel,.true.) - call hdf_getslab_r(tpoly%slope ,'SLOPE ' ,dsetrank,iparallel,.true.) - call hdf_getslab_r(tpoly%aspect ,'ASPECT ' ,dsetrank,iparallel,.true.) - call hdf_getslab_r(tpoly%TCI ,'TCI ' ,dsetrank,iparallel,.true.) - call hdf_getslab_i(tpoly%patch_count,'PATCH_COUNT ',dsetrank,iparallel,.true.) - - !----- Load 2D dataset, currently just the soil texture. ----------------------! - call hdf_getslab_i(tpoly%lsl ,'LSL_SI ' ,dsetrank,iparallel,.true.) - dsetrank = 2_8 - globdims(1) = int(dset_nzg,8) - chnkdims(1) = int(dset_nzg,8) - memdims(1) = int(dset_nzg,8) - memsize(1) = int(dset_nzg,8) - chnkoffs(1) = 0_8 - memoffs(1) = 0_8 - globdims(2) = int(dset_nsites_global,8) - chnkdims(2) = int(tpoly%nsites,8) - chnkoffs(2) = int(pysi_id(py_index) - 1,8) - memdims(2) = int(tpoly%nsites,8) - memsize(2) = int(tpoly%nsites,8) - memoffs(2) = 0_8 - call hdf_getslab_i(this_ntext,'NTEXT_SOIL_SI ',dsetrank,iparallel,.true.) + !------------------------------------------------------------------------------! - ! The input file may have different number of soil layers than this ! - ! simulation. This is not a problem at this point because the soil maps don't ! - ! have soil texture profiles, but it may become an issue for sites with ! - ! different soil types along the profile. Feel free to improve the code... ! - ! For the time being, we assume here that there is only one soil type, so all ! - ! that we need is to save one layer for each site. ! - !------------------------------------------------------------------------------! - do isi_try=1,nsites_inp - tpoly%ntext_soil(nzg,isi_try) = this_ntext(dset_nzg,isi_try) - end do + ! Loop over the sites, seeking only those that are land sites. ! !------------------------------------------------------------------------------! + is = 0 + siteloop1: do isi=1,pysi_n(py_index) + if (islakesite(isi) == 0) then + is = is + 1 + !------------------------------------------------------------------------! + ! Reset the HDF5 auxiliary variables before moving to the next ! + ! level. ! + !------------------------------------------------------------------------! + globdims = 0_8 + chnkdims = 0_8 + chnkoffs = 0_8 + memoffs = 0_8 + memdims = 0_8 + memsize = 1_8 + !------------------------------------------------------------------------! + + !------------------------------------------------------------------------! + ! SITE level variables. ! + !------------------------------------------------------------------------! + !----- Load 1D dataset. -------------------------------------------------! + dsetrank = 1_8 + globdims(1) = int(dset_nsites_global,8) + chnkdims(1) = int(1,8) + chnkoffs(1) = int(pysi_id(py_index) - 2 + isi,8) + memdims (1) = int(1,8) + memsize (1) = int(1,8) + memoffs (1) = 0_8 + + call hdf_getslab_r( tpoly_area (is:is) , 'AREA_SI ' & + , dsetrank, iparallel, .true.) + call hdf_getslab_r( tpoly_moist_f (is:is) , 'MOIST_F ' & + , dsetrank, iparallel, .true.) + call hdf_getslab_r( tpoly_moist_W (is:is) , 'MOIST_W ' & + , dsetrank, iparallel, .true.) + call hdf_getslab_r( tpoly_elevation (is:is) , 'ELEVATION ' & + , dsetrank, iparallel, .true.) + call hdf_getslab_r( tpoly_slope (is:is) , 'SLOPE ' & + , dsetrank, iparallel, .true.) + call hdf_getslab_r( tpoly_aspect (is:is) , 'ASPECT ' & + , dsetrank, iparallel, .true.) + call hdf_getslab_r( tpoly_TCI (is:is) , 'TCI ' & + , dsetrank, iparallel, .true.) + call hdf_getslab_i( tpoly_patch_count(is:is) , 'PATCH_COUNT ' & + , dsetrank, iparallel, .true.) + call hdf_getslab_i( tpoly_lsl (is:is) ,'LSL_SI ' & + , dsetrank, iparallel, .true.) + !------------------------------------------------------------------------! + + + !----- Load 2D dataset, currently just the soil texture. ----------------! + dsetrank = 2_8 + globdims(1) = int(dset_nzg,8) + chnkdims(1) = int(dset_nzg,8) + memdims(1) = int(dset_nzg,8) + memsize(1) = int(dset_nzg,8) + chnkoffs(1) = 0_8 + memoffs(1) = 0_8 + globdims(2) = int(dset_nsites_global,8) + chnkdims(2) = int(1,8) + chnkoffs(2) = int(pysi_id(py_index) - 2 + isi,8) + memdims(2) = int(1,8) + memsize(2) = int(1,8) + memoffs(2) = 0_8 + call hdf_getslab_i( this_ntext (:,is) , 'NTEXT_SOIL_SI ' & + , dsetrank, iparallel, .true.) + !------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------! + ! The input file may have different number of soil layers than this ! + ! simulation. This is not a problem at this point because the soil maps ! + ! don't have soil texture profiles, but it may become an issue for sites ! + ! with different soil types along the profile. Feel free to improve the ! + ! code... For the time being, we assume here that there is only one ! + ! soil type, so all that we need is to save one layer for each site. ! + !------------------------------------------------------------------------! + + tpoly_ntext_soil(nzg,is) = this_ntext(dset_nzg,is) + + !------------------------------------------------------------------------! + end if + !---------------------------------------------------------------------------! + end do siteloop1 + !------------------------------------------------------------------------------! !------------------------------------------------------------------------------! ! Loop over all sites and fill the patch-level variables. ! !------------------------------------------------------------------------------! - siteloop: do isi = 1,cpoly%nsites + siteloop2: do isi = 1,cpoly%nsites csite => cpoly%site(isi) nsoil = cpoly%ntext_soil(nzg,isi) @@ -1422,26 +1538,32 @@ subroutine read_ed21_history_unstruct ! Loop over the sites, pick up the closest one. ! !---------------------------------------------------------------------------! textdist_min = huge(1.) - do isi_try = 1, tpoly%nsites - nsoil_try = tpoly%ntext_soil(nzg,isi_try) - - !------------------------------------------------------------------------! - ! Find the "distance" between the two sites based on the sand and ! - ! clay contents. ! - !------------------------------------------------------------------------! - textdist_try = (soil(nsoil_try)%xsand - soil(nsoil)%xsand) ** 2 & - + (soil(nsoil_try)%xclay - soil(nsoil)%xclay) ** 2 - !------------------------------------------------------------------------! + is_try = 0 + do isi_try = 1, nsites_inp + if (islakesite(isi_try) == 0) then + is_try = is_try + 1 + nsoil_try = tpoly_ntext_soil(nzg,is_try) - !------------------------------------------------------------------------! - ! Hold this site in case the "distance" is the minimum so far. ! - !------------------------------------------------------------------------! - if (textdist_try < textdist_min) then - isi_best = isi_try - textdist_min = textdist_try + !---------------------------------------------------------------------! + ! Find the "distance" between the two sites based on the sand and ! + ! clay contents. ! + !---------------------------------------------------------------------! + textdist_try = (soil(nsoil_try)%xsand - soil(nsoil)%xsand) ** 2 & + + (soil(nsoil_try)%xclay - soil(nsoil)%xclay) ** 2 + !---------------------------------------------------------------------! + + + !---------------------------------------------------------------------! + ! Hold this site in case the "distance" is the minimum so far. ! + !---------------------------------------------------------------------! + if (textdist_try < textdist_min) then + isi_best = isi_try + is_best = is_try + textdist_min = textdist_try + end if + !---------------------------------------------------------------------! end if - !------------------------------------------------------------------------! end do !---------------------------------------------------------------------------! @@ -1453,13 +1575,13 @@ subroutine read_ed21_history_unstruct ! be different and we want them to be based on the user settings rather ! ! than the old run setting. ! !---------------------------------------------------------------------------! - cpoly%moist_f (isi) = tpoly%moist_f (isi_best) - cpoly%moist_w (isi) = tpoly%moist_w (isi_best) - cpoly%elevation (isi) = tpoly%elevation (isi_best) - cpoly%slope (isi) = tpoly%slope (isi_best) - cpoly%aspect (isi) = tpoly%aspect (isi_best) - cpoly%TCI (isi) = tpoly%TCI (isi_best) - cpoly%patch_count (isi) = tpoly%patch_count (isi_best) + cpoly%moist_f (isi) = tpoly_moist_f (is_best) + cpoly%moist_w (isi) = tpoly_moist_w (is_best) + cpoly%elevation (isi) = tpoly_elevation (is_best) + cpoly%slope (isi) = tpoly_slope (is_best) + cpoly%aspect (isi) = tpoly_aspect (is_best) + cpoly%TCI (isi) = tpoly_TCI (is_best) + cpoly%patch_count (isi) = tpoly_patch_count (is_best) !---------------------------------------------------------------------------! @@ -1530,9 +1652,9 @@ subroutine read_ed21_history_unstruct ! Make sure that no area is going to be zero for a given land ! ! use type when the counter part is not. ! !------------------------------------------------------------------! - oldarea(ilu) = max(0.5 * min_new_patch_area,oldarea(ilu)) - newarea(ilu,xclosest) = max(0.5 * min_new_patch_area & - ,newarea(ilu,xclosest)) + oldarea(ilu) = max( 0.5 * min_patch_area,oldarea(ilu)) + newarea(ilu,xclosest) = max( 0.5 * min_patch_area & + , newarea(ilu,xclosest)) !------------------------------------------------------------------! end do @@ -1578,7 +1700,6 @@ subroutine read_ed21_history_unstruct ! ones. ! !---------------------------------------------------------------------! csite%lai(ipa) = 0.0 - csite%wpa(ipa) = 0.0 csite%wai(ipa) = 0.0 csite%plant_ag_biomass(ipa) = 0.0 @@ -1758,19 +1879,17 @@ subroutine read_ed21_history_unstruct cpatch%basarea(ico) = pio4 * cpatch%dbh(ico) * cpatch%dbh(ico) - !----- Assign LAI, WPA, and WAI --------------------------------! + !----- Assign LAI, WAI, and CAI --------------------------------! call area_indices(cpatch%nplant(ico),cpatch%bleaf(ico) & ,cpatch%bdead(ico),cpatch%balive(ico) & ,cpatch%dbh(ico),cpatch%hite(ico) & ,cpatch%pft(ico),SLA(cpatch%pft(ico)) & - ,cpatch%lai(ico),cpatch%wpa(ico) & - ,cpatch%wai(ico),cpatch%crown_area(ico) & - ,cpatch%bsapwood(ico)) + ,cpatch%lai(ico),cpatch%wai(ico) & + ,cpatch%crown_area(ico),cpatch%bsapwood(ico)) !----- Update the derived patch-level variables. ---------------! csite%lai(ipa) = csite%lai(ipa) + cpatch%lai(ico) - csite%wpa(ipa) = csite%wpa(ipa) + cpatch%wpa(ico) csite%wai(ipa) = csite%wai(ipa) + cpatch%wai(ico) csite%plant_ag_biomass(ipa) = csite%plant_ag_biomass(ipa) & + cpatch%agb(ico)*cpatch%nplant(ico) @@ -1796,7 +1915,7 @@ subroutine read_ed21_history_unstruct !----- Initialise the other patch-level variables. -------------------------! call init_ed_patch_vars(csite,1,csite%npatches,cpoly%lsl(isi)) - end do siteloop + end do siteloop2 !----- Initialise some site-level variables. ----------------------------------! @@ -1804,9 +1923,18 @@ subroutine read_ed21_history_unstruct !------------------------------------------------------------------------------! !----- Deallocate the temporary polygon and soil structure. -------------------! - call deallocate_polygontype(tpoly) - deallocate(tpoly) - deallocate(this_ntext ) + deallocate (this_ntext ) + deallocate (tpoly_area ) + deallocate (tpoly_moist_f ) + deallocate (tpoly_moist_w ) + deallocate (tpoly_elevation ) + deallocate (tpoly_slope ) + deallocate (tpoly_aspect ) + deallocate (tpoly_TCI ) + deallocate (tpoly_patch_count ) + deallocate (tpoly_lsl ) + deallocate (tpoly_ntext_soil ) + deallocate (islakesite ) !------------------------------------------------------------------------------! end do polyloop diff --git a/ED/src/io/ed_xml_config.f90 b/ED/src/io/ed_xml_config.f90 index b31d249cf..097d3b03f 100644 --- a/ED/src/io/ed_xml_config.f90 +++ b/ED/src/io/ed_xml_config.f90 @@ -142,6 +142,8 @@ recursive subroutine read_ed_xml_config(filename) if(texist) sfilout = trim(cval) call getConfigINT ('ivegt_dynamics','misc',i,ival,texist) if(texist) ivegt_dynamics = ival + call getConfigINT ('ibigleaf','misc',i,ival,texist) + if(texist) ibigleaf = ival call getConfigINT ('integration_scheme','misc',i,ival,texist) if(texist) integration_scheme = ival @@ -652,7 +654,10 @@ recursive subroutine read_ed_xml_config(filename) !! GENERAL call getConfigREAL ('min_new_patch_area','disturbance',i,rval,texist) - if(texist) min_new_patch_area = real(rval) + if(texist) min_patch_area = real(rval) + !! GENERAL + call getConfigREAL ('min_patch_area','disturbance',i,rval,texist) + if(texist) min_patch_area = real(rval) call getConfigINT ('include_fire','disturbance',i,ival,texist) if(texist) include_fire = ival call getConfigINT ('ianth_disturb','disturbance',i,ival,texist) diff --git a/ED/src/io/edio.f90 b/ED/src/io/edio.f90 index c6d6362ed..4308119a2 100644 --- a/ED/src/io/edio.f90 +++ b/ED/src/io/edio.f90 @@ -312,23 +312,18 @@ subroutine spatial_averages use grid_coms , only : ngrids & ! intent(in) , nzg & ! intent(in) , nzs ! ! intent(in) - use consts_coms , only : alvl & ! intent(in) - , cpi & ! intent(in) - , wdns & ! intent(in) - , p00i & ! intent(in) - , t00 & ! intent(in) - , rocp & ! intent(in) - , umol_2_kgC & ! intent(in) - , day_sec ! ! intent(in) + use consts_coms , only : wdns & ! intent(in) + , t00 ! ! intent(in) use ed_misc_coms , only : frqsum ! ! intent(in) - use therm_lib , only : qwtk & ! subroutine - , qtk & ! subroutine - , idealdenssh ! ! function + use therm_lib , only : uextcm2tl & ! subroutine + , uint2tl & ! subroutine + , idealdenssh & ! function + , press2exner & ! function + , extheta2temp ! ! function use soil_coms , only : tiny_sfcwater_mass & ! intent(in) , isoilbc & ! intent(in) , soil & ! intent(in) , dslz ! ! intent(in) - use c34constants , only : n_stoma_atts ! ! intent(in) use ed_max_dims , only : n_pft ! ! intent(in) implicit none !----- Local variables -----------------------------------------------------------------! @@ -344,8 +339,6 @@ subroutine spatial_averages integer :: lai_index integer :: nsoil real :: lai_patch - real :: laiarea_site - real :: laiarea_poly real :: site_area_i real :: poly_area_i real :: frqsumi @@ -357,6 +350,7 @@ subroutine spatial_averages real :: dslzsum_i real :: rdepth real :: soil_mstpot + real :: can_exner !---------------------------------------------------------------------------------------! !----- Time scale for output. We will use the inverse more often. ---------------------! @@ -381,7 +375,6 @@ subroutine spatial_averages !----- Initialise some integrated variables --------------------------------------! area_sum = 0.0 - laiarea_poly = 0.0 poly_avg_soil_hcap = 0.0 !---------------------------------------------------------------------------------! @@ -444,7 +437,6 @@ subroutine spatial_averages !----- LAI --------------------------------------------------------------------! cpoly%lai(isi) = sum(csite%lai * csite%area ) * site_area_i - cpoly%wpa(isi) = sum(csite%wpa * csite%area ) * site_area_i cpoly%wai(isi) = sum(csite%wai * csite%area ) * site_area_i @@ -461,7 +453,6 @@ subroutine spatial_averages cpoly%avg_vapor_ac(isi) = sum(csite%avg_vapor_ac * csite%area ) * site_area_i cpoly%avg_transp(isi) = sum(csite%avg_transp * csite%area ) * site_area_i cpoly%avg_evap(isi) = sum(csite%avg_evap * csite%area ) * site_area_i - cpoly%aux(isi) = sum(csite%aux * csite%area ) * site_area_i cpoly%avg_drainage(isi) = sum(csite%avg_drainage * csite%area ) * site_area_i cpoly%avg_runoff(isi) = sum(csite%avg_runoff * csite%area ) * site_area_i cpoly%avg_drainage_heat(isi) = sum(csite%avg_drainage_heat * csite%area ) & @@ -532,8 +523,6 @@ subroutine spatial_averages * site_area_i cpoly%avg_transloss(:,isi) = matmul(csite%avg_transloss ,csite%area) & * site_area_i - cpoly%aux_s(:,isi) = matmul(csite%aux_s ,csite%area) & - * site_area_i cpoly%avg_soil_energy(:,isi) = matmul(csite%soil_energy ,csite%area) & * site_area_i cpoly%avg_soil_water(:,isi) = matmul(csite%soil_water ,csite%area) & @@ -578,12 +567,14 @@ subroutine spatial_averages + site_avg_soil_hcap(k) * cpoly%area(isi)*poly_area_i !----- Finding the average temperature and liquid fraction. ----------------! - call qwtk(cpoly%avg_soil_energy(k,isi),cpoly%avg_soil_water(k,isi)*wdns & - ,site_avg_soil_hcap(k),cpoly%avg_soil_temp(k,isi) & - ,cpoly%avg_soil_fracliq(k,isi)) + call uextcm2tl( cpoly%avg_soil_energy (k,isi) & + , cpoly%avg_soil_water (k,isi) * wdns & + , site_avg_soil_hcap (k) & + , cpoly%avg_soil_temp (k,isi) & + , cpoly%avg_soil_fracliq(k,isi) ) end do - !------------------------------------------------------------------------------! + !------------------------------------------------------------------------------! ! For layers beneath the lowest soil level, assign a default soil ! ! potential and soil moisture consistent with the boundary condition. ! !------------------------------------------------------------------------------! @@ -658,8 +649,8 @@ subroutine spatial_averages if (cpoly%avg_sfcw_mass(isi) > tiny_sfcwater_mass) then cpoly%avg_sfcw_energy(isi) = cpoly%avg_sfcw_energy(isi) & / cpoly%avg_sfcw_mass(isi) - call qtk(cpoly%avg_sfcw_energy(isi),cpoly%avg_sfcw_tempk(isi) & - ,cpoly%avg_sfcw_fracliq(isi)) + call uint2tl(cpoly%avg_sfcw_energy(isi),cpoly%avg_sfcw_tempk(isi) & + ,cpoly%avg_sfcw_fracliq(isi)) else cpoly%avg_sfcw_mass(isi) = 0. cpoly%avg_sfcw_depth(isi) = 0. @@ -692,9 +683,9 @@ subroutine spatial_averages !----- Check whether there is any heat storage. -------------------------! if (csite%avg_leaf_hcap(ipa) > 0.) then !----- Yes, use the default thermodynamics. --------------------------! - call qwtk(csite%avg_leaf_energy(ipa),csite%avg_leaf_water(ipa) & - ,csite%avg_leaf_hcap(ipa),csite%avg_leaf_temp(ipa) & - ,csite%avg_leaf_fliq(ipa)) + call uextcm2tl(csite%avg_leaf_energy(ipa),csite%avg_leaf_water(ipa) & + ,csite%avg_leaf_hcap(ipa),csite%avg_leaf_temp(ipa) & + ,csite%avg_leaf_fliq(ipa)) else !----- No, copy the canopy air properties. ---------------------------! csite%avg_leaf_temp(ipa) = csite%can_temp(ipa) @@ -715,9 +706,9 @@ subroutine spatial_averages !----- Check whether there is any heat storage. -------------------------! if (csite%avg_wood_hcap(ipa) > 0.) then !----- Yes, use the default thermodynamics. --------------------------! - call qwtk(csite%avg_wood_energy(ipa),csite%avg_wood_water(ipa) & - ,csite%avg_wood_hcap(ipa),csite%avg_wood_temp(ipa) & - ,csite%avg_wood_fliq(ipa)) + call uextcm2tl(csite%avg_wood_energy(ipa),csite%avg_wood_water(ipa) & + ,csite%avg_wood_hcap(ipa),csite%avg_wood_temp(ipa) & + ,csite%avg_wood_fliq(ipa)) else !----- No, copy the canopy air properties. ---------------------------! csite%avg_wood_temp(ipa) = csite%can_temp(ipa) @@ -888,12 +879,6 @@ subroutine spatial_averages end if end if - if (lai_patch > 0.) then - csite%laiarea(ipa) = csite%area(ipa) - else - csite%laiarea(ipa) = 0. - end if - cgrid%avg_htroph_resp(ipy) = cgrid%avg_htroph_resp(ipy) & + csite%mean_rh(ipa) & * csite%area(ipa)*cpoly%area(isi) & @@ -945,23 +930,6 @@ subroutine spatial_averages cohortloop: do ico=1,cpatch%ncohorts - cpatch%old_stoma_vector(1,ico) = real(cpatch%old_stoma_data(ico)%recalc) - cpatch%old_stoma_vector(2,ico) = cpatch%old_stoma_data(ico)%T_L - cpatch%old_stoma_vector(3,ico) = cpatch%old_stoma_data(ico)%e_A - cpatch%old_stoma_vector(4,ico) = cpatch%old_stoma_data(ico)%PAR - cpatch%old_stoma_vector(5,ico) = cpatch%old_stoma_data(ico)%rb_factor - cpatch%old_stoma_vector(6,ico) = cpatch%old_stoma_data(ico)%prss - cpatch%old_stoma_vector(7,ico) = cpatch%old_stoma_data(ico)%phenology_factor - cpatch%old_stoma_vector(8,ico) = cpatch%old_stoma_data(ico)%gsw_open - cpatch%old_stoma_vector(9,ico) = real(cpatch%old_stoma_data(ico)%ilimit) - - cpatch%old_stoma_vector(10,ico) = cpatch%old_stoma_data(ico)%T_L_residual - cpatch%old_stoma_vector(11,ico) = cpatch%old_stoma_data(ico)%e_a_residual - cpatch%old_stoma_vector(12,ico) = cpatch%old_stoma_data(ico)%par_residual - cpatch%old_stoma_vector(13,ico) = cpatch%old_stoma_data(ico)%rb_residual - cpatch%old_stoma_vector(14,ico) = cpatch%old_stoma_data(ico)%prss_residual - cpatch%old_stoma_vector(15,ico) = cpatch%old_stoma_data(ico)%leaf_residual - cpatch%old_stoma_vector(16,ico) = cpatch%old_stoma_data(ico)%gsw_residual !------------------------------------------------------------------------! @@ -977,37 +945,8 @@ subroutine spatial_averages end do cohortloop - - pftloop: do ipft = 1,n_pft - csite%old_stoma_vector_max(1,ipft,ipa) = real(csite%old_stoma_data_max(ipft,ipa)%recalc) - csite%old_stoma_vector_max(2,ipft,ipa) = csite%old_stoma_data_max(ipft,ipa)%T_L - csite%old_stoma_vector_max(3,ipft,ipa) = csite%old_stoma_data_max(ipft,ipa)%e_A - csite%old_stoma_vector_max(4,ipft,ipa) = csite%old_stoma_data_max(ipft,ipa)%PAR - csite%old_stoma_vector_max(5,ipft,ipa) = csite%old_stoma_data_max(ipft,ipa)%rb_factor - csite%old_stoma_vector_max(6,ipft,ipa) = csite%old_stoma_data_max(ipft,ipa)%prss - csite%old_stoma_vector_max(7,ipft,ipa) = csite%old_stoma_data_max(ipft,ipa)%phenology_factor - csite%old_stoma_vector_max(8,ipft,ipa) = csite%old_stoma_data_max(ipft,ipa)%gsw_open - csite%old_stoma_vector_max(9,ipft,ipa) = real(csite%old_stoma_data_max(ipft,ipa)%ilimit) - - csite%old_stoma_vector_max(10,ipft,ipa) = csite%old_stoma_data_max(ipft,ipa)%T_L_residual - csite%old_stoma_vector_max(11,ipft,ipa) = csite%old_stoma_data_max(ipft,ipa)%e_a_residual - csite%old_stoma_vector_max(12,ipft,ipa) = csite%old_stoma_data_max(ipft,ipa)%par_residual - csite%old_stoma_vector_max(13,ipft,ipa) = csite%old_stoma_data_max(ipft,ipa)%rb_residual - csite%old_stoma_vector_max(14,ipft,ipa) = csite%old_stoma_data_max(ipft,ipa)%prss_residual - csite%old_stoma_vector_max(15,ipft,ipa) = csite%old_stoma_data_max(ipft,ipa)%leaf_residual - csite%old_stoma_vector_max(16,ipft,ipa) = csite%old_stoma_data_max(ipft,ipa)%gsw_residual - end do pftloop - end do longpatchloop - laiarea_site = sum(csite%laiarea) - laiarea_poly = laiarea_poly + laiarea_site - if (laiarea_site == 0.0) then - csite%laiarea = 0.0 - else - csite%laiarea = csite%laiarea / laiarea_site - end if - ! Take an area weighted average of the root density to get site level fraction !------------------------------------------------------------------------------! @@ -1027,11 +966,11 @@ subroutine spatial_averages cpoly%avg_can_shv (isi) = sum(csite%can_shv * csite%area) * site_area_i cpoly%avg_can_co2 (isi) = sum(csite%can_co2 * csite%area) * site_area_i cpoly%avg_can_prss (isi) = sum(csite%can_prss * csite%area) * site_area_i - cpoly%avg_can_temp (isi) = cpoly%avg_can_theta(isi) & - * (p00i * cpoly%avg_can_prss(isi)) ** rocp - cpoly%avg_can_rhos (isi) = idealdenssh(cpoly%avg_can_prss(isi) & - ,cpoly%avg_can_temp(isi) & - ,cpoly%avg_can_shv (isi) ) + can_exner = press2exner (cpoly%avg_can_prss(isi)) + cpoly%avg_can_temp (isi) = extheta2temp(can_exner,cpoly%avg_can_theta (isi)) + cpoly%avg_can_rhos (isi) = idealdenssh( cpoly%avg_can_prss (isi) & + , cpoly%avg_can_temp (isi) & + , cpoly%avg_can_shv (isi) ) !------------------------------------------------------------------------------! ! Site average of leaf and stem properties. Again, we average "extensive" ! ! properties and find the average temperature based on the average leaf and ! @@ -1055,9 +994,9 @@ subroutine spatial_averages ! assign mean canopy temperature. ! !------------------------------------------------------------------------------! if (cpoly%avg_leaf_hcap(isi) > 0.) then - call qwtk(cpoly%avg_leaf_energy(isi),cpoly%avg_leaf_water(isi) & - ,cpoly%avg_leaf_hcap(isi),cpoly%avg_leaf_temp(isi) & - ,cpoly%avg_leaf_fliq(isi)) + call uextcm2tl(cpoly%avg_leaf_energy(isi),cpoly%avg_leaf_water(isi) & + ,cpoly%avg_leaf_hcap(isi),cpoly%avg_leaf_temp(isi) & + ,cpoly%avg_leaf_fliq(isi)) else cpoly%avg_leaf_temp(isi) = cpoly%avg_can_temp(isi) if (cpoly%avg_can_temp(isi) > t00) then @@ -1074,9 +1013,9 @@ subroutine spatial_averages ! ature. Otherwise, assign mean canopy temperature. ! !------------------------------------------------------------------------------! if (cpoly%avg_wood_hcap(isi) > 0.) then - call qwtk(cpoly%avg_wood_energy(isi),cpoly%avg_wood_water(isi) & - ,cpoly%avg_wood_hcap(isi),cpoly%avg_wood_temp(isi) & - ,cpoly%avg_wood_fliq(isi)) + call uextcm2tl(cpoly%avg_wood_energy(isi),cpoly%avg_wood_water(isi) & + ,cpoly%avg_wood_hcap(isi),cpoly%avg_wood_temp(isi) & + ,cpoly%avg_wood_fliq(isi)) else cpoly%avg_wood_temp(isi) = cpoly%avg_can_temp(isi) if (cpoly%avg_can_temp(isi) > t00) then @@ -1108,7 +1047,8 @@ subroutine spatial_averages skin_hcap = cpoly%avg_leaf_hcap(isi) & + cpoly%avg_wood_hcap(isi) & + site_avg_soil_hcap(nzg) * dslz(nzg) - call qwtk(skin_energy,skin_water,skin_hcap,cpoly%avg_skin_temp(isi),skin_fliq) + call uextcm2tl(skin_energy,skin_water,skin_hcap & + ,cpoly%avg_skin_temp(isi),skin_fliq) !------------------------------------------------------------------------------! end do siteloop !---------------------------------------------------------------------------------! @@ -1155,7 +1095,6 @@ subroutine spatial_averages !----- Finding the polygon mean LAI ----------------------------------------------! cgrid%lai(ipy) = sum(cpoly%lai * cpoly%area ) * poly_area_i - cgrid%wpa(ipy) = sum(cpoly%wpa * cpoly%area ) * poly_area_i cgrid%wai(ipy) = sum(cpoly%wai * cpoly%area ) * poly_area_i !----- Average fast time flux dynamics over polygons. ----------------------------! cgrid%avg_rshort_gnd(ipy) = sum(cpoly%avg_rshort_gnd *cpoly%area)*poly_area_i @@ -1181,7 +1120,6 @@ subroutine spatial_averages cgrid%avg_vapor_ac(ipy) = sum(cpoly%avg_vapor_ac *cpoly%area)*poly_area_i cgrid%avg_transp(ipy) = sum(cpoly%avg_transp *cpoly%area)*poly_area_i cgrid%avg_evap(ipy) = sum(cpoly%avg_evap *cpoly%area)*poly_area_i - cgrid%aux(ipy) = sum(cpoly%aux *cpoly%area)*poly_area_i cgrid%avg_sensible_lc(ipy) = sum(cpoly%avg_sensible_lc *cpoly%area)*poly_area_i cgrid%avg_sensible_wc(ipy) = sum(cpoly%avg_sensible_wc *cpoly%area)*poly_area_i cgrid%avg_qwshed_vg(ipy) = sum(cpoly%avg_qwshed_vg *cpoly%area)*poly_area_i @@ -1222,11 +1160,11 @@ subroutine spatial_averages cgrid%avg_can_shv (ipy) = sum(cpoly%avg_can_shv * cpoly%area) * poly_area_i cgrid%avg_can_co2 (ipy) = sum(cpoly%avg_can_co2 * cpoly%area) * poly_area_i cgrid%avg_can_prss (ipy) = sum(cpoly%avg_can_prss * cpoly%area) * poly_area_i - cgrid%avg_can_temp (ipy) = cgrid%avg_can_theta(ipy) & - * (p00i * cgrid%avg_can_prss(ipy)) ** rocp - cgrid%avg_can_rhos (ipy) = idealdenssh(cgrid%avg_can_prss(ipy) & - ,cgrid%avg_can_temp(ipy) & - ,cgrid%avg_can_shv (ipy) ) + can_exner = press2exner (cgrid%avg_can_prss(ipy)) + cgrid%avg_can_temp (ipy) = extheta2temp(can_exner,cgrid%avg_can_theta(ipy)) + cgrid%avg_can_rhos (ipy) = idealdenssh ( cgrid%avg_can_prss (ipy) & + , cgrid%avg_can_temp (ipy) & + , cgrid%avg_can_shv (ipy) ) !---------------------------------------------------------------------------------! ! Similar to the site level, average mass, heat capacity and energy then find ! ! the average temperature and liquid water fraction. ! @@ -1237,8 +1175,6 @@ subroutine spatial_averages * poly_area_i cgrid%avg_transloss (:,ipy) = matmul(cpoly%avg_transloss , cpoly%area) & * poly_area_i - cgrid%aux_s (:,ipy) = matmul(cpoly%aux_s , cpoly%area) & - * poly_area_i cgrid%avg_soil_energy (:,ipy) = matmul(cpoly%avg_soil_energy , cpoly%area) & * poly_area_i cgrid%avg_soil_water (:,ipy) = matmul(cpoly%avg_soil_water , cpoly%area) & @@ -1254,9 +1190,9 @@ subroutine spatial_averages ! Finding the average temperature and liquid fraction. The polygon-level ! ! mean heat capacity was already found during the site loop. ! !------------------------------------------------------------------------------! - call qwtk(cgrid%avg_soil_energy(k,ipy),cgrid%avg_soil_water(k,ipy)*wdns & - ,poly_avg_soil_hcap(k),cgrid%avg_soil_temp(k,ipy) & - ,cgrid%avg_soil_fracliq(k,ipy)) + call uextcm2tl(cgrid%avg_soil_energy(k,ipy),cgrid%avg_soil_water(k,ipy)*wdns & + ,poly_avg_soil_hcap(k),cgrid%avg_soil_temp(k,ipy) & + ,cgrid%avg_soil_fracliq(k,ipy)) end do cgrid%avg_soil_wetness(ipy) = sum(cpoly%avg_soil_wetness * cpoly%area) & * poly_area_i @@ -1275,8 +1211,8 @@ subroutine spatial_averages if (cgrid%avg_sfcw_mass(ipy) > tiny_sfcwater_mass) then cgrid%avg_sfcw_energy(ipy) = cgrid%avg_sfcw_energy(ipy) & / cgrid%avg_sfcw_mass(ipy) - call qtk(cgrid%avg_sfcw_energy(ipy),cgrid%avg_sfcw_tempk(ipy) & - ,cgrid%avg_sfcw_fracliq(ipy)) + call uint2tl(cgrid%avg_sfcw_energy(ipy),cgrid%avg_sfcw_tempk(ipy) & + ,cgrid%avg_sfcw_fracliq(ipy)) else cgrid%avg_sfcw_mass(ipy) = 0. cgrid%avg_sfcw_depth(ipy) = 0. @@ -1296,9 +1232,9 @@ subroutine spatial_averages cgrid%avg_wood_water(ipy) = sum(cpoly%avg_wood_water * cpoly%area) * poly_area_i cgrid%avg_wood_hcap(ipy) = sum(cpoly%avg_wood_hcap * cpoly%area) * poly_area_i if (cgrid%avg_leaf_hcap(ipy) > 0.) then - call qwtk(cgrid%avg_leaf_energy(ipy),cgrid%avg_leaf_water(ipy) & - ,cgrid%avg_leaf_hcap(ipy),cgrid%avg_leaf_temp(ipy) & - ,cgrid%avg_leaf_fliq(ipy)) + call uextcm2tl(cgrid%avg_leaf_energy(ipy),cgrid%avg_leaf_water(ipy) & + ,cgrid%avg_leaf_hcap(ipy),cgrid%avg_leaf_temp(ipy) & + ,cgrid%avg_leaf_fliq(ipy)) else cgrid%avg_leaf_temp(ipy) = cgrid%avg_can_temp(ipy) if (cgrid%avg_can_temp(ipy) > 0.0) then @@ -1310,9 +1246,9 @@ subroutine spatial_averages end if end if if (cgrid%avg_wood_hcap(ipy) > 0.) then - call qwtk(cgrid%avg_wood_energy(ipy),cgrid%avg_wood_water(ipy) & - ,cgrid%avg_wood_hcap(ipy),cgrid%avg_wood_temp(ipy) & - ,cgrid%avg_wood_fliq(ipy)) + call uextcm2tl(cgrid%avg_wood_energy(ipy),cgrid%avg_wood_water(ipy) & + ,cgrid%avg_wood_hcap(ipy),cgrid%avg_wood_temp(ipy) & + ,cgrid%avg_wood_fliq(ipy)) else cgrid%avg_wood_temp(ipy) = cgrid%avg_can_temp(ipy) if (cgrid%avg_can_temp(ipy) > 0.0) then @@ -1346,7 +1282,8 @@ subroutine spatial_averages skin_hcap = cgrid%avg_leaf_hcap(ipy) & + cgrid%avg_wood_hcap(ipy) & + poly_avg_soil_hcap(nzg) * dslz(nzg) - call qwtk(skin_energy,skin_water,skin_hcap,cgrid%avg_skin_temp(ipy),skin_fliq) + call uextcm2tl(skin_energy,skin_water,skin_hcap & + ,cgrid%avg_skin_temp(ipy),skin_fliq) !---------------------------------------------------------------------------------! end do polyloop diff --git a/ED/src/io/h5_output.F90 b/ED/src/io/h5_output.F90 index a812ee093..ad1631ba7 100644 --- a/ED/src/io/h5_output.F90 +++ b/ED/src/io/h5_output.F90 @@ -59,7 +59,6 @@ subroutine h5_output(vtype) !------ Arguments. ---------------------------------------------------------------------! character(len=*) , intent(in) :: vtype !------ Local variables. ---------------------------------------------------------------! - type(var_table_vector) , pointer :: vtvec character(len=str_len) :: anamel character(len=3) :: cgrid character(len=40) :: subaname @@ -105,6 +104,7 @@ subroutine h5_output(vtype) integer , save :: irec_opt = 0 !----- Local constants. ----------------------------------------------------------------! logical , parameter :: collective_mpi = .false. + logical , parameter :: verbose = .false. real(kind=8) , parameter :: zero = 0.0d0 !----- External functions. -------------------------------------------------------------! logical , external :: isleap @@ -112,6 +112,17 @@ subroutine h5_output(vtype) + !---------------------------------------------------------------------------------------! + ! Start with some banner just to make sure we got in here. ! + !---------------------------------------------------------------------------------------! + if (verbose) then + write (unit=*,fmt='(a,1x,a,a,1x,i6,a)') & + '+ HDF5. Analysis:',trim(vtype),'. Node:',mynum,'...' + end if + !---------------------------------------------------------------------------------------! + + + !----- Initialise some variables. ------------------------------------------------------! comm = MPI_COMM_WORLD info = MPI_INFO_NULL @@ -120,7 +131,6 @@ subroutine h5_output(vtype) !------ Find which letter we should use to denote this type of analysis. ---------------! - select case (trim(vtype)) case ('INST') vnam='I' ! Instantaneous analysis. @@ -139,34 +149,60 @@ subroutine h5_output(vtype) case ('CONT') vnam='Z' ! The first time with history start, so we don't replace the history end select - nvcnt=0 + !---------------------------------------------------------------------------------------! - nrec = 1 - irec = 1 + nvcnt = 0 + nrec = 1 + irec = 1 !---------------------------------------------------------------------------------------! ! Loop over the grids. ! !---------------------------------------------------------------------------------------! gridloop: do ngr=1,ngrids + if (verbose) write (unit=*,fmt='(2(a,1x,i6),a)') ' * Grid:',ngr,'. Node:',mynum,'...' + !----- I guess this cleans out anything that didn't finish correctly. ---------------! + if (verbose) write (unit=*,fmt='(a)') ' * Collect garbage...' call h5garbage_collect_f(hdferr) + !------------------------------------------------------------------------------------! !----- Wait until the previous node has finished writing. ---------------------------! new_file=.true. if (mynum /= 1) then - call MPI_RECV(new_file,1,MPI_LOGICAL,recvnum,3510+ngr,MPI_COMM_WORLD,status,ierr) + call MPI_Recv(new_file,1,MPI_LOGICAL,recvnum,3510+ngr,MPI_COMM_WORLD,status,ierr) + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Print a check about the file status. ! + !------------------------------------------------------------------------------------! + if (verbose) then + write (unit=*,fmt='(a,1x,a,2(a,1x,i6),a,1x,l,a)') & + ' * HDF5. Type:',trim(vtype),'. Node:',mynum,'. Grid: ',ngr & + ,'. New File:',new_file,'...' end if + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! ! If there are no polygons on this node, then the node shouldn't do anything to ! ! this file. This is something that happens only in coupled model runs. ! !------------------------------------------------------------------------------------! - if (gdpy(mynum,ngr)>0) then + if (gdpy(mynum,ngr) > 0) then + if (verbose) then + write (unit=*,fmt='(a,1x,i6,1x,a)') ' > Writing ',gdpy(mynum,ngr) & + ,'polygons...' + end if + !----- Make the grid flag. -------------------------------------------------------! write(cgrid,fmt='(a1,i2.2)') 'g',ngr + !---------------------------------------------------------------------------------! !---------------------------------------------------------------------------------! @@ -304,6 +340,7 @@ subroutine h5_output(vtype) !---------------------------------------------------------------------------------! ! Initialise the HDF5 environment. ! !---------------------------------------------------------------------------------! + if (verbose) write (unit=*,fmt='(a)') ' > Opening HDF5 environment...' call h5open_f(hdferr) if (hdferr /= 0) then write(unit=*,fmt='(a,1x,i)') ' - HDF5 Open error #:',hdferr @@ -318,6 +355,7 @@ subroutine h5_output(vtype) ! Either open or create the output file. ! !---------------------------------------------------------------------------------! if (new_file) then + if (verbose) write (unit=*,fmt='(a)') ' > Creating new file...' call h5fcreate_f(trim(anamel)//char(0), H5F_ACC_TRUNC_F, file_id, hdferr) if (hdferr /= 0) then @@ -330,6 +368,7 @@ subroutine h5_output(vtype) call fatal_error('Failed creating the HDF file','h5_output','h5_output.F90') end if else + if (verbose) write (unit=*,fmt='(a)') ' > Opening new file...' call h5fopen_f(trim(anamel)//char(0), H5F_ACC_RDWR_F, file_id, hdferr) if (hdferr /= 0) then write(unit=*,fmt='(a)' ) '--------------------------------------------' @@ -349,6 +388,10 @@ subroutine h5_output(vtype) ! Create HDF5 datasets and then put them in the file; we must loop over all ! ! variables. ! !---------------------------------------------------------------------------------! + if (verbose) then + write (unit=*,fmt='(a,1x,a,1x,a)') ' > Loop over ',num_var(ngr) & + ,'variables...' + end if varloop: do nv = 1,num_var(ngr) !----- Check whether the variable goes to the output. -------------------------! if ((vtype == 'INST' .and. vt_info(nv,ngr)%ianal == 1) .or. & @@ -370,11 +413,18 @@ subroutine h5_output(vtype) ,dsetrank,varn,nrec,irec) !---------------------------------------------------------------------------! + if (verbose) then + write (unit=*,fmt='(a,1x,a,5(a,1x,i12))') & + ' # Variable:',trim(varn),'. Type:',vt_info(nv,ngr)%idim_type & + ,'. Size:',vt_info(nv,ngr)%var_len_global,'. Rank:',dsetrank & + ,'. Nrec:',nrec,'. Irec:',irec + end if !---------------------------------------------------------------------------! ! Create the data set. ! !---------------------------------------------------------------------------! + if (verbose) write (unit=*,fmt='(a)') ' # Creating data set...' call h5screate_simple_f(dsetrank, globdims, filespace, hdferr) if (hdferr /= 0 .or. globdims(1) < 1 ) then write (unit=*,fmt='(a,1x,a)') ' VTYPE: ',trim(vtype) @@ -392,10 +442,12 @@ subroutine h5_output(vtype) !---------------------------------------------------------------------------! ! Determine whether the dataset exists. ! !---------------------------------------------------------------------------! + if (verbose) write (unit=*,fmt='(a)') ' # Opening file...' call h5eset_auto_f(0,hdferr) call h5dopen_f(file_id,varn,dset_id,hdferr) if (hdferr < 0) then + if (verbose) write (unit=*,fmt='(a)') ' # Eset auto (HDFERR < 0)...' call h5eset_auto_f(1,hdferr) select case (vt_info(nv,ngr)%dtype) @@ -431,6 +483,7 @@ subroutine h5_output(vtype) ! Attached metadata if the user wants it. ! !------------------------------------------------------------------------! if (attach_metadata == 1) then + if (verbose) write (unit=*,fmt='(a)') ' # Attaching metadata...' arank = 1 adims = 3_8 attrlen = 64_8 @@ -470,8 +523,11 @@ subroutine h5_output(vtype) call h5aclose_f(attr_id,hdferr) call h5sclose_f(aspace_id,hdferr) + elseif (verbose) then + write (unit=*,fmt='(a)') ' # Skipping metadata...' end if + if (verbose) write (unit=*,fmt='(a)') ' # Creating dataset...' call h5dopen_f(file_id,varn,dset_id,hdferr) if (hdferr /= 0) then @@ -488,9 +544,11 @@ subroutine h5_output(vtype) ,'h5_output','h5_output.F90') end if else + if (verbose) write (unit=*,fmt='(a)') ' # Eset auto (HDFERR >=0)...' call h5eset_auto_f(1,hdferr) end if + if (verbose) write (unit=*,fmt='(a)') ' # Closing filespace...' call h5sclose_f(filespace,hdferr) if (hdferr /= 0) then call fatal_error('Could not close the first filespace' & @@ -501,23 +559,49 @@ subroutine h5_output(vtype) !---------------------------------------------------------------------------! ! Loop over all the pointers. ! !---------------------------------------------------------------------------! + if (verbose) then + write (unit=*,fmt='(a,1x,i12,1x,a)') & + ' # Looping over ',vt_info(nv,ngr)%nptrs,'pointers ...' + end if pointerloop: do iptr = 1,vt_info(nv,ngr)%nptrs - - vtvec => vt_info(nv,ngr)%vt_vector(iptr) + if (verbose) then + write (unit=*,fmt='(a,1x,i12,1x,a)') ' ~ Pointer ',iptr,'...' + end if + + !------------------------------------------------------------------------! ! Set the size of the chunk and it's offset in the global dataset. ! !------------------------------------------------------------------------! - if (vtvec%varlen > 0 ) then + if (vt_info(nv,ngr)%vt_vector(iptr)%varlen > 0 ) then + if (verbose) then + write (unit=*,fmt='(a,1x,i12,1x,a)') & + ' + Length',vt_info(nv,ngr)%vt_vector(iptr)%varlen,'...' + end if !---------------------------------------------------------------------! ! Evaluate the variable output type. Resolve the dimensioning ! ! and the meta-data tags accordingly. See ed_state_vars.f90 for a ! ! description of the various datatype. ! !---------------------------------------------------------------------! !----- Initialize hyperslab indices. ---------------------------------! - call geth5dims(vt_info(nv,ngr)%idim_type,vtvec%varlen,vtvec%globid & + call geth5dims(vt_info(nv,ngr)%idim_type & + ,vt_info(nv,ngr)%vt_vector(iptr)%varlen & + ,vt_info(nv,ngr)%vt_vector(iptr)%globid & ,vt_info(nv,ngr)%var_len_global,dsetrank,varn,nrec,irec) - + + + + if (verbose) then + write (unit=*,fmt='(5(a,1x,i12))') & + ' + Type:',vt_info(nv,ngr)%idim_type & + ,'. Size:',vt_info(nv,ngr)%var_len_global,'. Rank:',dsetrank & + ,'. Nrec:',nrec,'. Irec:',irec + end if + !----- Create the data space for the dataset. ------------------------! + if (verbose) then + write (unit=*,fmt='(a)') ' + Create data space...' + end if + call h5screate_simple_f(dsetrank, chnkdims, memspace, hdferr) if (hdferr /= 0) then write (unit=*,fmt=*) 'Chunk dimension: ',chnkdims @@ -529,12 +613,18 @@ subroutine h5_output(vtype) end if !----- Get the hyperslab in the file. --------------------------------! + if (verbose) then + write (unit=*,fmt='(a)') ' + Get hyperslab in the file...' + end if call h5dget_space_f(dset_id,filespace,hdferr) if (hdferr /= 0) then call fatal_error('Could not get the hyperslabs filespace' & ,'h5_output','h5_output.F90') end if + if (verbose) then + write (unit=*,fmt='(a)') ' + Select hyperslab...' + end if call h5sselect_hyperslab_f(filespace,H5S_SELECT_SET_F,chnkoffs,cnt & ,hdferr,stride,chnkdims) if (hdferr /= 0) then @@ -546,45 +636,58 @@ subroutine h5_output(vtype) !---------------------------------------------------------------------! ! Choose the right pointer when writing the variable. ! !---------------------------------------------------------------------! + if (verbose) then + write (unit=*,fmt='(a,1x,a,a)') & + ' + Write variable of type ' & + ,vt_info(nv,ngr)%dtype,'...' + end if select case (vt_info(nv,ngr)%dtype) case ('R') !----- Real variable (vector). ----------------------------! - call h5dwrite_f(dset_id,H5T_NATIVE_REAL,vtvec%var_rp,globdims & - ,hdferr,file_space_id=filespace & + call h5dwrite_f(dset_id,H5T_NATIVE_REAL & + ,vt_info(nv,ngr)%vt_vector(iptr)%var_rp & + ,globdims,hdferr,file_space_id=filespace & ,mem_space_id=memspace) case ('D') !----- Double precision variable (vector). ----------------! - call h5dwrite_f(dset_id,H5T_NATIVE_DOUBLE,vtvec%var_dp,globdims & - ,hdferr,file_space_id=filespace & + call h5dwrite_f(dset_id,H5T_NATIVE_DOUBLE & + ,vt_info(nv,ngr)%vt_vector(iptr)%var_dp & + ,globdims,hdferr,file_space_id=filespace & ,mem_space_id=memspace) case ('I') !----- Integer variable (vector). -------------------------! - call h5dwrite_f(dset_id,H5T_NATIVE_INTEGER,vtvec%var_ip,globdims & - ,hdferr,file_space_id=filespace & + call h5dwrite_f(dset_id,H5T_NATIVE_INTEGER & + ,vt_info(nv,ngr)%vt_vector(iptr)%var_ip & + ,globdims,hdferr,file_space_id=filespace & ,mem_space_id=memspace) case ('C') !----- Character variable (vector). -----------------------! - call h5dwrite_f(dset_id,H5T_NATIVE_CHARACTER,vtvec%var_cp,globdims & + call h5dwrite_f(dset_id,H5T_NATIVE_CHARACTER & + ,vt_info(nv,ngr)%vt_vector(iptr)%var_cp,globdims & ,hdferr,file_space_id=filespace & ,mem_space_id = memspace) case ('r') !----- Real variable (scalar). ----------------------------! - call h5dwrite_f(dset_id,H5T_NATIVE_REAL,vtvec%sca_rp,globdims & - ,hdferr,file_space_id=filespace & + call h5dwrite_f(dset_id,H5T_NATIVE_REAL & + ,vt_info(nv,ngr)%vt_vector(iptr)%sca_rp & + ,globdims,hdferr,file_space_id=filespace & ,mem_space_id=memspace) case ('d') !----- Double precision variable (scalar). ----------------! - call h5dwrite_f(dset_id,H5T_NATIVE_DOUBLE,vtvec%sca_dp,globdims & - ,hdferr,file_space_id=filespace & + call h5dwrite_f(dset_id,H5T_NATIVE_DOUBLE & + ,vt_info(nv,ngr)%vt_vector(iptr)%sca_dp & + ,globdims,hdferr,file_space_id=filespace & ,mem_space_id=memspace) case ('i') !----- Integer variable (scalar). -------------------------! - call h5dwrite_f(dset_id,H5T_NATIVE_INTEGER,vtvec%sca_ip,globdims & - ,hdferr,file_space_id=filespace & + call h5dwrite_f(dset_id,H5T_NATIVE_INTEGER & + ,vt_info(nv,ngr)%vt_vector(iptr)%sca_ip & + ,globdims,hdferr,file_space_id=filespace & ,mem_space_id=memspace) case ('c') !----- Character variable (scalar). -----------------------! - call h5dwrite_f(dset_id,H5T_NATIVE_CHARACTER,vtvec%sca_cp,globdims & - ,hdferr,file_space_id=filespace & + call h5dwrite_f(dset_id,H5T_NATIVE_CHARACTER & + ,vt_info(nv,ngr)%vt_vector(iptr)%sca_cp & + ,globdims,hdferr,file_space_id=filespace & ,mem_space_id=memspace) end select @@ -599,43 +702,59 @@ subroutine h5_output(vtype) ,'h5_output','h5_output.F90') end if - + if (verbose) then + write (unit=*,fmt='(a)') ' + Close hyperslab filespace...' + end if call h5sclose_f(filespace,hdferr) if (hdferr /= 0) then call fatal_error('Could not close the hyperslabs filespace' & ,'h5_output','h5_output.F90') end if + if (verbose) then + write (unit=*,fmt='(a)') ' + Close hyperslab memspace...' + end if call h5sclose_f(memspace,hdferr) if (hdferr /= 0) then call fatal_error('Could not close the hyperslabs memspace' & ,'h5_output','h5_output.F90') end if + elseif (verbose) then + write (unit=*,fmt='(a)') ' + Length 0, skipping...' end if end do pointerloop !---------------------------------------------------------------------------! + if (verbose) write (unit=*,fmt='(a)') ' # Close dataset...' call h5dclose_f(dset_id,hdferr) if (hdferr /= 0) then - call fatal_error('Could not get the dataset','h5_output','h5_output.F90') + call fatal_error('Could not close dataset','h5_output','h5_output.F90') end if - + elseif (verbose) then + write (unit=*,fmt='(a,1x,a)') & + ' # Skipping variable:',trim(varn) & + ,', as it doesn''t belong to this file...' end if end do varloop !---------------------------------------------------------------------------------! + if (verbose) write (unit=*,fmt='(a)') ' > Closing file...' call h5fclose_f(file_id,hdferr) if (hdferr /= 0) then call fatal_error('Could not close the file','h5_output','h5_output.F90') end if + if (verbose) write (unit=*,fmt='(a)') ' > Closing HDF5 environment...' call h5close_f(hdferr) if (hdferr /= 0) then call fatal_error('Could not close the hdf environment' & ,'h5_output','h5_output.F90') end if + if (verbose) write (unit=*,fmt='(a)') ' > Success!' new_file = .false. + elseif (verbose) then + write (unit=*,fmt='(a)') ' > No polygons in this node... ' end if !------------------------------------------------------------------------------------! @@ -723,7 +842,6 @@ subroutine geth5dims(idim_type,varlen,globid,var_len_global,dsetrank,varn,nrec,i , stride & ! intent(in) , globdims ! ! intent(in) use fusion_fission_coms, only : ff_nhgt ! ! intent(in) - use c34constants , only : n_stoma_atts ! ! intent(in) use ed_misc_coms , only : ndcycle ! ! intent(in) implicit none @@ -1171,23 +1289,6 @@ subroutine geth5dims(idim_type,varlen,globid,var_len_global,dsetrank,varn,nrec,i cnt(1:3) = 1_8 stride(1:3) = 1_8 - case (316) ! (n_stoma_atts,n_pft,npatches) - - dsetrank = 3 - globdims(1) = int(n_stoma_atts,8) - chnkdims(1) = int(n_stoma_atts,8) - chnkoffs(1) = 0_8 - - globdims(2) = int(n_pft,8) - chnkdims(2) = int(n_pft,8) - chnkoffs(2) = 0_8 - - globdims(3) = int(var_len_global,8) - chnkdims(3) = int(varlen,8) - chnkoffs(3) = int(globid,8) - cnt(1:3) = 1_8 - stride(1:3) = 1_8 - case (36) !(n_dbh,npatches) diff --git a/ED/src/memory/c34constants.f90 b/ED/src/memory/c34constants.f90 index df39604c4..a9b24b37d 100644 --- a/ED/src/memory/c34constants.f90 +++ b/ED/src/memory/c34constants.f90 @@ -142,38 +142,6 @@ module c34constants !---------------------------------------------------------------------------------------! - - !---------------------------------------------------------------------------------------! - ! This structure contains the variables that may be copied to the model standard ! - ! output. ! - !---------------------------------------------------------------------------------------! - type stoma_data - integer :: recalc=1 !THIS SHOULD BE INIT IN ED_PARAMS - real(kind=4) :: T_L - real(kind=4) :: e_A - real(kind=4) :: PAR - real(kind=4) :: rb_factor - real(kind=4) :: prss - real(kind=4) :: phenology_factor - real(kind=4) :: gsw_open - integer :: ilimit - - real(kind=4) :: T_L_residual - real(kind=4) :: e_a_residual - real(kind=4) :: par_residual - real(kind=4) :: rb_residual - real(kind=4) :: prss_residual - real(kind=4) :: leaf_residual - real(kind=4) :: gsw_residual - end type stoma_data - !---------------------------------------------------------------------------------------! - - - !------ The number of stomatal attributes. ---------------------------------------------! - integer, parameter :: n_stoma_atts = 16 - !---------------------------------------------------------------------------------------! - - !=======================================================================================! !=======================================================================================! diff --git a/ED/src/memory/canopy_layer_coms.f90 b/ED/src/memory/canopy_layer_coms.f90 index 9356c7468..a29eee798 100644 --- a/ED/src/memory/canopy_layer_coms.f90 +++ b/ED/src/memory/canopy_layer_coms.f90 @@ -19,6 +19,14 @@ module canopy_layer_coms !---------------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------------! + ! For big-leaf version of ED, we must define the target thickness of each layer in ! + ! terms of total (leaf+wood) area index. ! + !---------------------------------------------------------------------------------------! + real :: tai_lyr_max + !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! ! Variables that define the number of layers in the canopy. ! ! The height of the top of each layer is defined as: ! diff --git a/ED/src/memory/consts_coms.F90 b/ED/src/memory/consts_coms.F90 index 02b67b2f7..0b484ad85 100644 --- a/ED/src/memory/consts_coms.F90 +++ b/ED/src/memory/consts_coms.F90 @@ -6,105 +6,317 @@ Module consts_coms ! This is done only when compiling the ED-BRAMS coupled code. This will make sure ! ! that all constants are defined in the same way in both models. ! !---------------------------------------------------------------------------------------! - use rconstants, only: & - b_pi1 => pi1 , b_twopi => twopi , b_pio180 => pio180 & - , b_pi4 => pi4 , b_pio4 => pio4 , b_srtwo => srtwo & - , b_srthree => srthree , b_srtwoi => srtwoi , b_srthreei => srthreei & - , b_onethird => onethird , b_stefan => stefan , b_boltzmann => boltzmann & - , b_t00 => t00 , b_yr_day => yr_day , b_day_sec => day_sec & - , b_day_hr => day_hr , b_hr_sec => hr_sec , b_min_sec => min_sec & - , b_vonk => vonk , b_grav => grav , b_erad => erad & - , b_p00 => p00 , b_p00i => p00i , b_rdry => rdry & - , b_cp => cp , b_cpog => cpog , b_rocp => rocp & - , b_cpor => cpor , b_cpi => cpi , b_rh2o => rh2o & - , b_ep => ep , b_epi => epi , b_toodry => toodry & - , b_cliq => cliq , b_cliqvlme => cliqvlme , b_cliqi => cliqi & - , b_cice => cice , b_cicevlme => cicevlme , b_cicei => cicei & - , b_t3ple => t3ple , b_t3plei => t3plei , b_es3ple => es3ple & - , b_es3plei => es3plei , b_epes3ple => epes3ple , b_alvl => alvl & - , b_alvi => alvi , b_alli => alli , b_allivlme => allivlme & - , b_allii => allii , b_wdns => wdns , b_erad2 => erad2 & - , b_sqrtpii => sqrtpii , b_onesixth => onesixth , b_qicet3 => qicet3 & - , b_wdnsi => wdnsi , b_gorh2o => gorh2o , b_idns => idns & - , b_idnsi => idnsi , b_tsupercool => tsupercool , b_twothirds => twothirds & - , b_qliqt3 => qliqt3 , b_sqrt2o2 => sqrt2o2 , b_mmdry => mmdry & - , b_mmh2o => mmh2o , b_mmco2 => mmco2 , b_mmdoc => mmdoc & - , b_mmcod => mmcod , b_mmdry1000 => mmdry1000 , b_mmdryi => mmdryi & - , b_rmol => rmol , b_volmol => volmol , b_volmoll => volmoll & - , b_mmcod1em6 => mmcod1em6 , b_mmco2i => mmco2i , b_epim1 => epim1 & - , b_ttripoli => ttripoli , b_htripoli => htripoli , b_htripolii => htripolii & - , b_cpi4 => cpi4 , b_aklv => aklv , b_akiv => akiv & - , b_rdryi => rdryi , b_eta3ple => eta3ple , b_cimcp => cimcp & - , b_clmcp => clmcp , b_p00k => p00k , b_p00ki => p00ki & - , b_halfpi => halfpi , b_yr_sec => yr_sec , b_sqrttwopi => sqrttwopi & - , b_sqrthalfpi => sqrthalfpi , b_fdns => fdns , b_fdnsi => fdnsi & - , b_cv => cv , b_cpocv => cpocv , b_rocv => rocv & - , b_hr_min => hr_min , b_th_diff => th_diff , b_th_diffi => th_diffi & - , b_kin_visc => kin_visc , b_kin_visci => kin_visci , b_th_expan => th_expan & - , b_gr_coeff => gr_coeff , b_mmh2oi => mmh2oi , b_lnexp_min => lnexp_min & - , b_lnexp_max => lnexp_max , b_huge_num => huge_num , b_tiny_num => tiny_num & - , b_mmo2 => mmo2 , b_mmo3 => mmo3 , b_prefsea => prefsea & - , b_solar => solar , b_euler_gam => euler_gam + use rconstants, only : b_pi1 => pi1 & ! intent(in) + , b_pii => pii & ! intent(in) + , b_halfpi => halfpi & ! intent(in) + , b_twopi => twopi & ! intent(in) + , b_pio180 => pio180 & ! intent(in) + , b_onerad => onerad & ! intent(in) + , b_pi4 => pi4 & ! intent(in) + , b_pi4o3 => pi4o3 & ! intent(in) + , b_pio4 => pio4 & ! intent(in) + , b_pio6 => pio6 & ! intent(in) + , b_pio6i => pio6i & ! intent(in) + , b_sqrtpii => sqrtpii & ! intent(in) + , b_sqrthalfpi => sqrthalfpi & ! intent(in) + , b_sqrttwopi => sqrttwopi & ! intent(in) + , b_euler_gam => euler_gam & ! intent(in) + , b_srtwo => srtwo & ! intent(in) + , b_srthree => srthree & ! intent(in) + , b_sqrt2o2 => sqrt2o2 & ! intent(in) + , b_srtwoi => srtwoi & ! intent(in) + , b_srthreei => srthreei & ! intent(in) + , b_onethird => onethird & ! intent(in) + , b_twothirds => twothirds & ! intent(in) + , b_onesixth => onesixth & ! intent(in) + , b_stefan => stefan & ! intent(in) + , b_boltzmann => boltzmann & ! intent(in) + , b_avogrado => avogrado & ! intent(in) + , b_loschmidt => loschmidt & ! intent(in) + , b_loschcgs => loschcgs & ! intent(in) + , b_t00 => t00 & ! intent(in) + , b_rmol => rmol & ! intent(in) + , b_rmolcgs => rmolcgs & ! intent(in) + , b_volmol => volmol & ! intent(in) + , b_volmoll => volmoll & ! intent(in) + , b_mmdry => mmdry & ! intent(in) + , b_mmo2 => mmo2 & ! intent(in) + , b_mmo3 => mmo3 & ! intent(in) + , b_mmh2o => mmh2o & ! intent(in) + , b_mmco2 => mmco2 & ! intent(in) + , b_mmdrycgs => mmdrycgs & ! intent(in) + , b_mmo2cgs => mmo2cgs & ! intent(in) + , b_mmo3cgs => mmo3cgs & ! intent(in) + , b_mmh2ocgs => mmh2ocgs & ! intent(in) + , b_mmco2cgs => mmco2cgs & ! intent(in) + , b_mmdoc => mmdoc & ! intent(in) + , b_mmcod => mmcod & ! intent(in) + , b_mmdry1000 => mmdry1000 & ! intent(in) + , b_mmcod1em6 => mmcod1em6 & ! intent(in) + , b_mmdryi => mmdryi & ! intent(in) + , b_mmh2oi => mmh2oi & ! intent(in) + , b_mmco2i => mmco2i & ! intent(in) + , b_yr_day => yr_day & ! intent(in) + , b_day_sec => day_sec & ! intent(in) + , b_day_hr => day_hr & ! intent(in) + , b_hr_sec => hr_sec & ! intent(in) + , b_hr_min => hr_min & ! intent(in) + , b_min_sec => min_sec & ! intent(in) + , b_yr_sec => yr_sec & ! intent(in) + , b_vonk => vonk & ! intent(in) + , b_grav => grav & ! intent(in) + , b_gcgs => gcgs & ! intent(in) + , b_gg => gg & ! intent(in) + , b_erad => erad & ! intent(in) + , b_spcon => spcon & ! intent(in) + , b_spconkm => spconkm & ! intent(in) + , b_eradi => eradi & ! intent(in) + , b_erad2 => erad2 & ! intent(in) + , b_ss60 => ss60 & ! intent(in) + , b_omega => omega & ! intent(in) + , b_viscos => viscos & ! intent(in) + , b_solar => solar & ! intent(in) + , b_p00 => p00 & ! intent(in) + , b_prefsea => prefsea & ! intent(in) + , b_p00i => p00i & ! intent(in) + , b_th_diff => th_diff & ! intent(in) + , b_th_diffi => th_diffi & ! intent(in) + , b_kin_visc => kin_visc & ! intent(in) + , b_kin_visci => kin_visci & ! intent(in) + , b_th_expan => th_expan & ! intent(in) + , b_gr_coeff => gr_coeff & ! intent(in) + , b_rdry => rdry & ! intent(in) + , b_rdryi => rdryi & ! intent(in) + , b_cpdry => cpdry & ! intent(in) + , b_cvdry => cvdry & ! intent(in) + , b_cpog => cpog & ! intent(in) + , b_rocp => rocp & ! intent(in) + , b_rocv => rocv & ! intent(in) + , b_cpocv => cpocv & ! intent(in) + , b_cpor => cpor & ! intent(in) + , b_cvor => cvor & ! intent(in) + , b_gocp => gocp & ! intent(in) + , b_gordry => gordry & ! intent(in) + , b_cpdryi => cpdryi & ! intent(in) + , b_cpdryi4 => cpdryi4 & ! intent(in) + , b_p00or => p00or & ! intent(in) + , b_p00k => p00k & ! intent(in) + , b_p00ki => p00ki & ! intent(in) + , b_rh2o => rh2o & ! intent(in) + , b_cph2o => cph2o & ! intent(in) + , b_cph2oi => cph2oi & ! intent(in) + , b_cvh2o => cvh2o & ! intent(in) + , b_gorh2o => gorh2o & ! intent(in) + , b_ep => ep & ! intent(in) + , b_epi => epi & ! intent(in) + , b_epim1 => epim1 & ! intent(in) + , b_toodry => toodry & ! intent(in) + , b_toowet => toowet & ! intent(in) + , b_wdns => wdns & ! intent(in) + , b_wdnsi => wdnsi & ! intent(in) + , b_cliq => cliq & ! intent(in) + , b_cliqi => cliqi & ! intent(in) + , b_idns => idns & ! intent(in) + , b_idnsi => idnsi & ! intent(in) + , b_fdns => fdns & ! intent(in) + , b_fdnsi => fdnsi & ! intent(in) + , b_cice => cice & ! intent(in) + , b_cicei => cicei & ! intent(in) + , b_t3ple => t3ple & ! intent(in) + , b_t3plei => t3plei & ! intent(in) + , b_es3ple => es3ple & ! intent(in) + , b_es3plei => es3plei & ! intent(in) + , b_epes3ple => epes3ple & ! intent(in) + , b_rh2ot3ple => rh2ot3ple & ! intent(in) + , b_alli => alli & ! intent(in) + , b_alvl3 => alvl3 & ! intent(in) + , b_alvi3 => alvi3 & ! intent(in) + , b_allii => allii & ! intent(in) + , b_aklv => aklv & ! intent(in) + , b_akiv => akiv & ! intent(in) + , b_lvordry => lvordry & ! intent(in) + , b_lvorvap => lvorvap & ! intent(in) + , b_lsorvap => lsorvap & ! intent(in) + , b_lvt3ple => lvt3ple & ! intent(in) + , b_lst3ple => lst3ple & ! intent(in) + , b_uiicet3 => uiicet3 & ! intent(in) + , b_uiliqt3 => uiliqt3 & ! intent(in) + , b_dcpvl => dcpvl & ! intent(in) + , b_dcpvi => dcpvi & ! intent(in) + , b_del_alvl3 => del_alvl3 & ! intent(in) + , b_del_alvi3 => del_alvi3 & ! intent(in) + , b_tsupercool_liq => tsupercool_liq & ! intent(in) + , b_tsupercool_vap => tsupercool_vap & ! intent(in) + , b_ttripoli => ttripoli & ! intent(in) + , b_htripoli => htripoli & ! intent(in) + , b_htripolii => htripolii & ! intent(in) + , b_tkmin => tkmin & ! intent(in) + , b_sigwmin => sigwmin & ! intent(in) + , b_abslmomin => abslmomin & ! intent(in) + , b_ltscalemax => ltscalemax & ! intent(in) + , b_abswltlmin => abswltlmin & ! intent(in) + , b_lturbmin => lturbmin & ! intent(in) + , b_lnexp_min => lnexp_min & ! intent(in) + , b_lnexp_max => lnexp_max & ! intent(in) + , b_huge_num => huge_num & ! intent(in) + , b_tiny_num => tiny_num ! ! intent(in) implicit none - - real, parameter :: pi1 = b_pi1 , twopi = b_twopi - real, parameter :: pio180 = b_pio180 , pi4 = b_pi4 - real, parameter :: pio4 = b_pio4 , srtwo = b_srtwo - real, parameter :: srthree = b_srthree , srtwoi = b_srtwoi - real, parameter :: srthreei = b_srthreei , onethird = b_onethird - real, parameter :: twothirds = b_twothirds , stefan = b_stefan - real, parameter :: boltzmann = b_boltzmann , tsupercool = b_tsupercool - real, parameter :: t00 = b_t00 , yr_day = b_yr_day - real, parameter :: day_sec = b_day_sec , day_hr = b_day_hr - real, parameter :: hr_sec = b_hr_sec , min_sec = b_min_sec - real, parameter :: vonk = b_vonk , grav = b_grav - real, parameter :: erad = b_erad , p00 = b_p00 - real, parameter :: p00i = b_p00i , rdry = b_rdry - real, parameter :: cp = b_cp , cpog = b_cpog - real, parameter :: rocp = b_rocp , cpor = b_cpor - real, parameter :: cpi = b_cpi , rh2o = b_rh2o - real, parameter :: ep = b_ep , epi = b_epi - real, parameter :: toodry = b_toodry , cliq = b_cliq - real, parameter :: cliqvlme = b_cliqvlme , cliqi = b_cliqi - real, parameter :: cice = b_cice , cicevlme = b_cicevlme - real, parameter :: cicei = b_cicei , t3ple = b_t3ple - real, parameter :: t3plei = b_t3plei , es3ple = b_es3ple - real, parameter :: es3plei = b_es3plei , epes3ple = b_epes3ple - real, parameter :: alvl = b_alvl , alvi = b_alvi - real, parameter :: alli = b_alli , allivlme = b_allivlme - real, parameter :: allii = b_allii , wdns = b_wdns - real, parameter :: erad2 = b_erad2 , sqrtpii = b_sqrtpii - real, parameter :: onesixth = b_onesixth , qicet3 = b_qicet3 - real, parameter :: wdnsi = b_wdnsi , gorh2o = b_gorh2o - real, parameter :: idns = b_idns , idnsi = b_idnsi - real, parameter :: qliqt3 = b_qliqt3 , sqrt2o2 = b_sqrt2o2 - real, parameter :: mmdry = b_mmdry , mmh2o = b_mmh2o - real, parameter :: mmco2 = b_mmco2 , mmdoc = b_mmdoc - real, parameter :: mmcod = b_mmcod , mmdry1000 = b_mmdry1000 - real, parameter :: mmdryi = b_mmdryi , rmol = b_rmol - real, parameter :: volmol = b_volmol , volmoll = b_volmoll - real, parameter :: mmcod1em6 = b_mmcod1em6 , mmco2i = b_mmco2i - real, parameter :: epim1 = b_epim1 , ttripoli = b_ttripoli - real, parameter :: htripoli = b_htripoli , htripolii = b_htripolii - real, parameter :: cpi4 = b_cpi4 , aklv = b_aklv - real, parameter :: akiv = b_akiv , rdryi = b_rdryi - real, parameter :: eta3ple = b_eta3ple , cimcp = b_cimcp - real, parameter :: clmcp = b_clmcp , p00k = b_p00k - real, parameter :: p00ki = b_p00ki , halfpi = b_halfpi - real, parameter :: yr_sec = b_yr_sec , sqrthalfpi = b_sqrthalfpi - real, parameter :: sqrttwopi = b_sqrttwopi , fdns = b_fdns - real, parameter :: fdnsi = b_fdnsi , cv = b_cv - real, parameter :: rocv = b_rocv , cpocv = b_cpocv - real, parameter :: hr_min = b_hr_min , th_diff = b_th_diff - real, parameter :: th_diffi = b_th_diffi , kin_visc = b_kin_visc - real, parameter :: th_expan = b_th_expan , gr_coeff = b_gr_coeff - real, parameter :: mmh2oi = b_mmh2o , lnexp_min = b_lnexp_min - real, parameter :: lnexp_max = b_lnexp_max , kin_visci = b_kin_visci - real, parameter :: huge_num = b_huge_num , tiny_num = b_tiny_num - real, parameter :: mmo2 = b_mmo2 , mmo3 = b_mmo3 - real, parameter :: prefsea = b_prefsea , solar = b_solar - real, parameter :: euler_gam = b_euler_gam + !----- Copy the variables from BRAMS. --------------------------------------------------! + real, parameter :: pi1 = b_pi1 + real, parameter :: pii = b_pii + real, parameter :: halfpi = b_halfpi + real, parameter :: twopi = b_twopi + real, parameter :: pio180 = b_pio180 + real, parameter :: onerad = b_onerad + real, parameter :: pi4 = b_pi4 + real, parameter :: pi4o3 = b_pi4o3 + real, parameter :: pio4 = b_pio4 + real, parameter :: pio6 = b_pio6 + real, parameter :: pio6i = b_pio6i + real, parameter :: sqrtpii = b_sqrtpii + real, parameter :: sqrthalfpi = b_sqrthalfpi + real, parameter :: sqrttwopi = b_sqrttwopi + real, parameter :: euler_gam = b_euler_gam + real, parameter :: srtwo = b_srtwo + real, parameter :: srthree = b_srthree + real, parameter :: sqrt2o2 = b_sqrt2o2 + real, parameter :: srtwoi = b_srtwoi + real, parameter :: srthreei = b_srthreei + real, parameter :: onethird = b_onethird + real, parameter :: twothirds = b_twothirds + real, parameter :: onesixth = b_onesixth + real, parameter :: stefan = b_stefan + real, parameter :: boltzmann = b_boltzmann + real, parameter :: avogrado = b_avogrado + real, parameter :: loschmidt = b_loschmidt + real, parameter :: loschcgs = b_loschcgs + real, parameter :: t00 = b_t00 + real, parameter :: rmol = b_rmol + real, parameter :: rmolcgs = b_rmolcgs + real, parameter :: volmol = b_volmol + real, parameter :: volmoll = b_volmoll + real, parameter :: mmdry = b_mmdry + real, parameter :: mmo2 = b_mmo2 + real, parameter :: mmo3 = b_mmo3 + real, parameter :: mmh2o = b_mmh2o + real, parameter :: mmco2 = b_mmco2 + real, parameter :: mmdrycgs = b_mmdrycgs + real, parameter :: mmo2cgs = b_mmo2cgs + real, parameter :: mmo3cgs = b_mmo3cgs + real, parameter :: mmh2ocgs = b_mmh2ocgs + real, parameter :: mmco2cgs = b_mmco2cgs + real, parameter :: mmdoc = b_mmdoc + real, parameter :: mmcod = b_mmcod + real, parameter :: mmdry1000 = b_mmdry1000 + real, parameter :: mmcod1em6 = b_mmcod1em6 + real, parameter :: mmdryi = b_mmdryi + real, parameter :: mmh2oi = b_mmh2oi + real, parameter :: mmco2i = b_mmco2i + real, parameter :: yr_day = b_yr_day + real, parameter :: day_sec = b_day_sec + real, parameter :: day_hr = b_day_hr + real, parameter :: hr_sec = b_hr_sec + real, parameter :: hr_min = b_hr_min + real, parameter :: min_sec = b_min_sec + real, parameter :: yr_sec = b_yr_sec + real, parameter :: vonk = b_vonk + real, parameter :: grav = b_grav + real, parameter :: gcgs = b_gcgs + real, parameter :: gg = b_gg + real, parameter :: erad = b_erad + real, parameter :: spcon = b_spcon + real, parameter :: spconkm = b_spconkm + real, parameter :: eradi = b_eradi + real, parameter :: erad2 = b_erad2 + real, parameter :: ss60 = b_ss60 + real, parameter :: omega = b_omega + real, parameter :: viscos = b_viscos + real, parameter :: solar = b_solar + real, parameter :: p00 = b_p00 + real, parameter :: prefsea = b_prefsea + real, parameter :: p00i = b_p00i + real, parameter :: th_diff = b_th_diff + real, parameter :: th_diffi = b_th_diffi + real, parameter :: kin_visc = b_kin_visc + real, parameter :: kin_visci = b_kin_visci + real, parameter :: th_expan = b_th_expan + real, parameter :: gr_coeff = b_gr_coeff + real, parameter :: rdry = b_rdry + real, parameter :: rdryi = b_rdryi + real, parameter :: cpdry = b_cpdry + real, parameter :: cvdry = b_cvdry + real, parameter :: cpog = b_cpog + real, parameter :: rocp = b_rocp + real, parameter :: rocv = b_rocv + real, parameter :: cpocv = b_cpocv + real, parameter :: cpor = b_cpor + real, parameter :: cvor = b_cvor + real, parameter :: gocp = b_gocp + real, parameter :: gordry = b_gordry + real, parameter :: cpdryi = b_cpdryi + real, parameter :: cpdryi4 = b_cpdryi4 + real, parameter :: p00or = b_p00or + real, parameter :: p00k = b_p00k + real, parameter :: p00ki = b_p00ki + real, parameter :: rh2o = b_rh2o + real, parameter :: cph2o = b_cph2o + real, parameter :: cph2oi = b_cph2oi + real, parameter :: cvh2o = b_cvh2o + real, parameter :: gorh2o = b_gorh2o + real, parameter :: ep = b_ep + real, parameter :: epi = b_epi + real, parameter :: epim1 = b_epim1 + real, parameter :: toodry = b_toodry + real, parameter :: toowet = b_toowet + real, parameter :: wdns = b_wdns + real, parameter :: wdnsi = b_wdnsi + real, parameter :: cliq = b_cliq + real, parameter :: cliqi = b_cliqi + real, parameter :: idns = b_idns + real, parameter :: idnsi = b_idnsi + real, parameter :: fdns = b_fdns + real, parameter :: fdnsi = b_fdnsi + real, parameter :: cice = b_cice + real, parameter :: cicei = b_cicei + real, parameter :: t3ple = b_t3ple + real, parameter :: t3plei = b_t3plei + real, parameter :: es3ple = b_es3ple + real, parameter :: es3plei = b_es3plei + real, parameter :: epes3ple = b_epes3ple + real, parameter :: rh2ot3ple = b_rh2ot3ple + real, parameter :: alli = b_alli + real, parameter :: alvl3 = b_alvl3 + real, parameter :: alvi3 = b_alvi3 + real, parameter :: allii = b_allii + real, parameter :: aklv = b_aklv + real, parameter :: akiv = b_akiv + real, parameter :: lvordry = b_lvordry + real, parameter :: lvorvap = b_lvorvap + real, parameter :: lsorvap = b_lsorvap + real, parameter :: lvt3ple = b_lvt3ple + real, parameter :: lst3ple = b_lst3ple + real, parameter :: uiicet3 = b_uiicet3 + real, parameter :: uiliqt3 = b_uiliqt3 + real, parameter :: dcpvl = b_dcpvl + real, parameter :: dcpvi = b_dcpvi + real, parameter :: del_alvl3 = b_del_alvl3 + real, parameter :: del_alvi3 = b_del_alvi3 + real, parameter :: tsupercool_liq = b_tsupercool_liq + real, parameter :: tsupercool_vap = b_tsupercool_vap + real, parameter :: ttripoli = b_ttripoli + real, parameter :: htripoli = b_htripoli + real, parameter :: htripolii = b_htripolii + real, parameter :: tkmin = b_tkmin + real, parameter :: sigwmin = b_sigwmin + real, parameter :: abslmomin = b_abslmomin + real, parameter :: ltscalemax = b_ltscalemax + real, parameter :: abswltlmin = b_abswltlmin + real, parameter :: lturbmin = b_lturbmin + real, parameter :: lnexp_min = b_lnexp_min + real, parameter :: lnexp_max = b_lnexp_max + real, parameter :: huge_num = b_huge_num + real, parameter :: tiny_num = b_tiny_num !---------------------------------------------------------------------------------------! #else @@ -234,17 +446,21 @@ Module consts_coms !---------------------------------------------------------------------------------------! ! Dry air properties ! !---------------------------------------------------------------------------------------! - real, parameter :: rdry = rmol/mmdry ! Gas constant for dry air (Ra) [ J/kg/K] - real, parameter :: rdryi = mmdry/rmol ! 1./Gas constant for dry air (Ra) [ kg K/J] - real, parameter :: cp = 3.5*rdry ! Specific heat at constant pressure [ J/kg/K] - real, parameter :: cv = 2.5 * rdry ! Specific heat at constant volume [ J/kg/K] - real, parameter :: rocp = rdry / cp ! Ra/cp [ ----] - real, parameter :: rocv = rdry / cv ! Ra/cv [ ----] - real, parameter :: cpocv = cp / cv ! Cp/Cv [ ----] - real, parameter :: cpog = cp /grav ! cp/g [ m/K] - real, parameter :: cpor = cp / rdry ! Cp/Ra [ ----] - real, parameter :: cpi = 1. / cp ! 1/Cp [ kg K/J] - real, parameter :: cpi4 = 4. * cpi ! 4/Cp [ kg K/J] + real, parameter :: rdry = rmol/mmdry ! Gas constant for dry air (Ra) [ J/kg/K] + real, parameter :: rdryi = mmdry/rmol ! 1./Gas const. for dry air (Ra) [ kg K/J] + real, parameter :: cpdry = 3.5 * rdry ! Spec. heat at constant press. [ J/kg/K] + real, parameter :: cvdry = 2.5 * rdry ! Spec. heat at constant volume [ J/kg/K] + real, parameter :: cpog = cpdry /grav ! cp/g [ m/K] + real, parameter :: rocp = rdry / cpdry ! Ra/cp [ ----] + real, parameter :: rocv = rdry / cvdry ! Ra/Cv [ ----] + real, parameter :: cpocv = cpdry / cvdry ! Cp/Cv [ ----] + real, parameter :: cpor = cpdry / rdry ! Cp/Ra [ ----] + real, parameter :: cvor = cvdry / rdry ! Cp/Ra [ ----] + real, parameter :: gocp = grav / cpdry ! g/Cp, dry adiabatic lapse rate [ K/m] + real, parameter :: gordry = grav / rdry ! g/Ra [ K/m] + real, parameter :: cpdryi = 1. / cpdry ! 1/Cp [ kg K/J] + real, parameter :: cpdryi4 = 4. * cpdryi ! 4/Cp [ kg K/J] + real, parameter :: p00or = p00 / rdry ! p0 ** (Ra/Cp) [ Pa^2/7] !---------------------------------------------------------------------------------------! @@ -252,12 +468,16 @@ Module consts_coms !---------------------------------------------------------------------------------------! ! Water vapour properties ! !---------------------------------------------------------------------------------------! - real, parameter :: rh2o = rmol / mmh2o ! Gas constant for water vapour (Rv)[ J/kg/K] - real, parameter :: gorh2o = grav / rh2o ! g/Rv [ K/m] - real, parameter :: ep = mmh2o/mmdry ! or Ra/Rv, epsilon, used to find rv[ kg/kg] - real, parameter :: epi = mmdry/mmh2o ! or Rv/Ra, 1/epsilon [ kg/kg] - real, parameter :: epim1 = epi-1. ! that 0.61 term of virtual temp. [ kg/kg] - real, parameter :: toodry = 1.e-8 ! Minimum acceptable mixing ratio. [ kg/kg] + real, parameter :: rh2o = rmol/mmh2o ! Gas const. for water vapour (Rv) [ J/kg/K] + real, parameter :: cph2o = 1859. ! Heat capacity at const. pres. [ J/kg/K] + real, parameter :: cph2oi = 1. / cph2o ! Inverse of heat capacity [ kg K/J] + real, parameter :: cvh2o = cph2o-rh2o ! Heat capacity at const. volume [ J/kg/K] + real, parameter :: gorh2o = grav / rh2o ! g/Rv [ K/m] + real, parameter :: ep = mmh2o/mmdry ! or Ra/Rv, epsilon [ kg/kg] + real, parameter :: epi = mmdry/mmh2o ! or Rv/Ra, 1/epsilon [ kg/kg] + real, parameter :: epim1 = epi-1. ! that 0.61 term of virtual temp. [ kg/kg] + real, parameter :: toodry = 1.e-8 ! Minimum acceptable mixing ratio. [ kg/kg] + real, parameter :: toowet = 3.e-2 ! Maximum acceptable mixing ratio. [ kg/kg] !---------------------------------------------------------------------------------------! @@ -268,7 +488,6 @@ Module consts_coms real, parameter :: wdns = 1.000e3 ! Liquid water density [ kg/m³] real, parameter :: wdnsi = 1./wdns ! Inverse of liquid water density [ m³/kg] real, parameter :: cliq = 4.186e3 ! Liquid water specific heat (Cl) [ J/kg/K] - real, parameter :: cliqvlme = wdns*cliq ! Water heat capacity × water dens. [ J/m³/K] real, parameter :: cliqi = 1./cliq ! Inverse of water heat capacity [ kg K/J] !---------------------------------------------------------------------------------------! @@ -282,7 +501,6 @@ Module consts_coms real, parameter :: fdns = 2.000e2 ! Frost density [ kg/m³] real, parameter :: fdnsi = 1./fdns ! Inverse of frost density [ m³/kg] real, parameter :: cice = 2.093e3 ! Ice specific heat (Ci) [ J/kg/K] - real, parameter :: cicevlme = wdns * cice ! Heat capacity × water density [ J/m³/K] real, parameter :: cicei = 1. / cice ! Inverse of ice heat capacity [ kg K/J] !---------------------------------------------------------------------------------------! @@ -292,32 +510,51 @@ Module consts_coms !---------------------------------------------------------------------------------------! ! Phase change properties ! !---------------------------------------------------------------------------------------! - real, parameter :: t3ple = 273.16 ! Water triple point temp. (T3) [ K] - real, parameter :: t3plei = 1./t3ple ! 1./T3 [ 1/K] - real, parameter :: es3ple = 611.65685464 ! Vapour pressure at T3 (es3) [ Pa] - real, parameter :: es3plei = 1./es3ple ! 1./es3 [ 1/Pa] - real, parameter :: epes3ple = ep * es3ple ! epsilon × es3 [ Pa kg/kg] - real, parameter :: alvl = 2.50e6 ! Lat. heat - vaporisation (Lv) [ J/kg] - real, parameter :: alvi = 2.834e6 ! Lat. heat - sublimation (Ls) [ J/kg] - real, parameter :: alli = 3.34e5 ! Lat. heat - fusion (Lf) [ J/kg] - real, parameter :: allivlme = wdns * alli ! Lat. heat × water density [ J/m³] - real, parameter :: allii = 1./alli ! 1/Latent heat - fusion [ kg/J] - real, parameter :: aklv = alvl / cp ! Lv/Cp [ K] - real, parameter :: akiv = alvi / cp ! Ls/Cp [ K] - real, parameter :: qicet3 = cice * t3ple ! q at triple point, only ice [ J/kg] - real, parameter :: qliqt3 = qicet3 + alli ! q at triple point, only liquid [ J/kg] + real, parameter :: t3ple = 273.16 ! Water triple point temp. (T3)[ K] + real, parameter :: t3plei = 1./t3ple ! 1./T3 [ 1/K] + real, parameter :: es3ple = 611.65685464 ! Vapour pressure at T3 (es3) [ Pa] + real, parameter :: es3plei = 1./es3ple ! 1./es3 [ 1/Pa] + real, parameter :: epes3ple = ep * es3ple ! epsilon × es3 [ Pa kg/kg] + real, parameter :: rh2ot3ple = rh2o * t3ple ! Rv × T3 [ J/kg] + real, parameter :: alli = 3.34e5 ! Lat. heat - fusion (Lf)[ J/kg] + real, parameter :: alvl3 = 2.50e6 ! Lat. heat - vaporisation (Lv)[ J/kg] + real, parameter :: alvi3 = alli + alvl3 ! Lat. heat - sublimation (Ls)[ J/kg] + real, parameter :: allii = 1. / alli ! 1./Lf [ kg/J] + real, parameter :: aklv = alvl3 / cpdry ! Lv/Cp [ K] + real, parameter :: akiv = alvi3 / cpdry ! Ls/Cp [ K] + real, parameter :: lvordry = alvl3 / rdry ! Lv/Ra [ K] + real, parameter :: lvorvap = alvl3 / rh2o ! Lv/Rv [ K] + real, parameter :: lsorvap = alvi3 / rh2o ! Ls/Rv [ K] + real, parameter :: lvt3ple = alvl3 * t3ple ! Lv × T3 [ K J/kg] + real, parameter :: lst3ple = alvi3 * t3ple ! Ls × T3 [ K J/kg] + real, parameter :: uiicet3 = cice * t3ple ! u at triple point, only ice [ J/kg] + real, parameter :: uiliqt3 = uiicet3 + alli ! u at triple point, only liq. [ J/kg] + real, parameter :: dcpvl = cph2o - cliq ! difference of sp. heat [ J/kg/K] + real, parameter :: dcpvi = cph2o - cice ! difference of sp. heat [ J/kg/K] + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! The following variables are useful when defining the derivatives of theta_il. ! + ! They correspond to L?(T) - L?' T. ! + !---------------------------------------------------------------------------------------! + real, parameter :: del_alvl3 = alvl3 - dcpvl * t3ple + real, parameter :: del_alvi3 = alvi3 - dcpvi * t3ple !---------------------------------------------------------------------------------------! !---------------------------------------------------------------------------------------! - ! Tsupercool is the temperature of supercooled water that will cause the energy to ! - ! be the same as ice at 0K. It can be used as an offset for temperature when defining ! - ! internal energy. The next two methods of defining the internal energy for the liquid ! - ! part: ! + ! Tsupercool are defined as temperatures of supercooled liquid water (water vapour) ! + ! that will cause the internal energy (enthalpy) to be the same as ice at 0K. It can ! + ! be used as an offset for temperature when defining internal energy (enthalpy). The ! + ! next two methods of defining the internal energy for the liquid part: ! + ! ! + ! Uliq = Mliq [ Cice T3 + Cliq (T - T3) + Lf] ! + ! Uliq = Mliq Cliq (T - Tsupercool_liq) ! ! ! - ! Uliq = Mliq × [ Cice × T3 + Cliq × (T - T3) + Lf] ! - ! Uliq = Mliq × Cliq × (T - Tsupercool) ! + ! H = Mliq [ Cice T3 + Cliq (Ts - T3) + Lv3 + (Cpv - Cliq) (Ts-T3) + Cpv (T-T3) ] ! + ! H = Mliq Cpv (T - Tsupercool_vap) ] ! ! ! ! You may be asking yourself why would we have the ice term in the internal energy ! ! definition. The reason is that we can think that internal energy is the amount of ! @@ -325,20 +562,8 @@ Module consts_coms ! prefer the inverse way, Uliq is the amount of energy the parcel would need to lose to ! ! become solid at 0K.) ! !---------------------------------------------------------------------------------------! - real, parameter :: tsupercool = t3ple - (qicet3+alli) * cliqi - !---------------------------------------------------------------------------------------! - - - - !---------------------------------------------------------------------------------------! - ! eta3ple is a constant related to the triple point that is used to find enthalpy ! - ! when the equilibrium temperature is above t3ple, whereas cimcp is the difference ! - ! between the heat capacity of ice and vapour, which is assumed to be the same as the ! - ! dry air, for simplicity. ! - !---------------------------------------------------------------------------------------! - real, parameter :: eta3ple = (cice - cliq) * t3ple + alvi - real, parameter :: cimcp = cice - cp - real, parameter :: clmcp = cliq - cp + real, parameter :: tsupercool_liq = t3ple - (uiicet3 + alli ) * cliqi + real, parameter :: tsupercool_vap = t3ple - (uiicet3 + alvi3) * cph2oi !---------------------------------------------------------------------------------------! @@ -352,9 +577,9 @@ Module consts_coms ! ature as a thermodynamic variable in deep atmospheric models. Mon. Wea. Rev., ! ! v. 109, 1094-1102. ! !---------------------------------------------------------------------------------------! - real, parameter :: ttripoli = 253. ! "Tripoli-Cotton" temp. (Ttr) [ K] - real, parameter :: htripoli = cp*ttripoli ! Sensible enthalpy at T=Ttr [ J/kg] - real, parameter :: htripolii = 1./htripoli ! 1./htripoli [ kg/J] + real, parameter :: ttripoli = 253. ! "Tripoli-Cotton" temp. (Ttr) [ K] + real, parameter :: htripoli = cpdry*ttripoli ! Sensible enthalpy at T=Ttr [ J/kg] + real, parameter :: htripolii = 1./htripoli ! 1./htripoli [ kg/J] !---------------------------------------------------------------------------------------! @@ -421,9 +646,9 @@ Module consts_coms real(kind=8), parameter :: volmol8 = dble(volmol ) real(kind=8), parameter :: volmoll8 = dble(volmoll ) real(kind=8), parameter :: mmdry8 = dble(mmdry ) + real(kind=8), parameter :: mmh2o8 = dble(mmh2o ) real(kind=8), parameter :: mmo28 = dble(mmo2 ) real(kind=8), parameter :: mmo38 = dble(mmo3 ) - real(kind=8), parameter :: mmh2o8 = dble(mmh2o ) real(kind=8), parameter :: mmco28 = dble(mmco2 ) real(kind=8), parameter :: mmdoc8 = dble(mmdoc ) real(kind=8), parameter :: mmcod8 = dble(mmcod ) @@ -447,16 +672,19 @@ Module consts_coms real(kind=8), parameter :: p00ki8 = dble(p00ki ) real(kind=8), parameter :: rdry8 = dble(rdry ) real(kind=8), parameter :: rdryi8 = dble(rdryi ) - real(kind=8), parameter :: cp8 = dble(cp ) - real(kind=8), parameter :: cv8 = dble(cv ) + real(kind=8), parameter :: cpdry8 = dble(cpdry ) + real(kind=8), parameter :: cvdry8 = dble(cvdry ) real(kind=8), parameter :: cpog8 = dble(cpog ) real(kind=8), parameter :: rocp8 = dble(rocp ) real(kind=8), parameter :: rocv8 = dble(rocv ) real(kind=8), parameter :: cpocv8 = dble(cpocv ) real(kind=8), parameter :: cpor8 = dble(cpor ) - real(kind=8), parameter :: cpi8 = dble(cpi ) - real(kind=8), parameter :: cpi48 = dble(cpi4 ) + real(kind=8), parameter :: cpdryi8 = dble(cpdryi ) + real(kind=8), parameter :: cpdryi48 = dble(cpdryi4 ) real(kind=8), parameter :: rh2o8 = dble(rh2o ) + real(kind=8), parameter :: cph2o8 = dble(cph2o ) + real(kind=8), parameter :: cph2oi8 = dble(cph2oi ) + real(kind=8), parameter :: cvh2o8 = dble(cvh2o ) real(kind=8), parameter :: gorh2o8 = dble(gorh2o ) real(kind=8), parameter :: ep8 = dble(ep ) real(kind=8), parameter :: epi8 = dble(epi ) @@ -465,54 +693,51 @@ Module consts_coms real(kind=8), parameter :: wdns8 = dble(wdns ) real(kind=8), parameter :: wdnsi8 = dble(wdnsi ) real(kind=8), parameter :: cliq8 = dble(cliq ) - real(kind=8), parameter :: cliqvlme8 = dble(cliqvlme ) real(kind=8), parameter :: cliqi8 = dble(cliqi ) real(kind=8), parameter :: idns8 = dble(idns ) real(kind=8), parameter :: idnsi8 = dble(idnsi ) real(kind=8), parameter :: fdns8 = dble(fdns ) real(kind=8), parameter :: fdnsi8 = dble(fdnsi ) real(kind=8), parameter :: cice8 = dble(cice ) - real(kind=8), parameter :: cicevlme8 = dble(cicevlme ) real(kind=8), parameter :: cicei8 = dble(cicei ) real(kind=8), parameter :: t3ple8 = dble(t3ple ) real(kind=8), parameter :: t3plei8 = dble(t3plei ) real(kind=8), parameter :: es3ple8 = dble(es3ple ) real(kind=8), parameter :: es3plei8 = dble(es3plei ) real(kind=8), parameter :: epes3ple8 = dble(epes3ple ) - real(kind=8), parameter :: alvl8 = dble(alvl ) - real(kind=8), parameter :: alvi8 = dble(alvi ) + real(kind=8), parameter :: alvl38 = dble(alvl3 ) + real(kind=8), parameter :: alvi38 = dble(alvi3 ) real(kind=8), parameter :: alli8 = dble(alli ) - real(kind=8), parameter :: allivlme8 = dble(allivlme ) real(kind=8), parameter :: allii8 = dble(allii ) - real(kind=8), parameter :: aklv8 = dble(aklv ) real(kind=8), parameter :: akiv8 = dble(akiv ) - real(kind=8), parameter :: qicet38 = dble(qicet3 ) - real(kind=8), parameter :: qliqt38 = dble(qliqt3 ) - real(kind=8), parameter :: tsupercool8 = dble(tsupercool ) - real(kind=8), parameter :: eta3ple8 = dble(eta3ple ) - real(kind=8), parameter :: cimcp8 = dble(cimcp ) - real(kind=8), parameter :: clmcp8 = dble(clmcp ) + real(kind=8), parameter :: aklv8 = dble(aklv ) + real(kind=8), parameter :: uiicet38 = dble(uiicet3 ) + real(kind=8), parameter :: uiliqt38 = dble(uiliqt3 ) + real(kind=8), parameter :: dcpvl8 = dble(dcpvl ) + real(kind=8), parameter :: dcpvi8 = dble(dcpvi ) + real(kind=8), parameter :: del_alvl38 = dble(del_alvl3 ) + real(kind=8), parameter :: del_alvi38 = dble(del_alvi3 ) + real(kind=8), parameter :: tsupercool_liq8 = dble(tsupercool_liq) + real(kind=8), parameter :: tsupercool_vap8 = dble(tsupercool_vap) real(kind=8), parameter :: ttripoli8 = dble(ttripoli ) real(kind=8), parameter :: htripoli8 = dble(htripoli ) real(kind=8), parameter :: htripolii8 = dble(htripolii ) - real(kind=8), parameter :: umol_2_kgC8 = dble(umol_2_kgC ) - real(kind=8), parameter :: kgom2_2_tonoha8 = dble(kgom2_2_tonoha) - real(kind=8), parameter :: tonoha_2_kgom28 = dble(tonoha_2_kgom2) real(kind=8), parameter :: th_diff8 = dble(th_diff ) real(kind=8), parameter :: th_diffi8 = dble(th_diffi ) real(kind=8), parameter :: kin_visc8 = dble(kin_visc ) real(kind=8), parameter :: kin_visci8 = dble(kin_visci ) real(kind=8), parameter :: th_expan8 = dble(th_expan ) real(kind=8), parameter :: gr_coeff8 = dble(gr_coeff ) - real(kind=8), parameter :: Watts_2_Ein8 = dble(Watts_2_Ein ) - real(kind=8), parameter :: Ein_2_Watts8 = dble(Ein_2_Watts ) - real(kind=8), parameter :: mol_2_umol8 = dble(mol_2_umol ) - real(kind=8), parameter :: umol_2_mol8 = dble(umol_2_mol ) real(kind=8), parameter :: lnexp_min8 = dble(lnexp_min ) real(kind=8), parameter :: lnexp_max8 = dble(lnexp_max ) real(kind=8), parameter :: huge_num8 = dble(huge_num ) real(kind=8), parameter :: tiny_num8 = dble(tiny_num ) real(kind=8), parameter :: euler_gam8 = dble(euler_gam ) + real(kind=8), parameter :: mol_2_umol8 = dble(mol_2_umol ) + real(kind=8), parameter :: umol_2_mol8 = dble(umol_2_mol ) + real(kind=8), parameter :: umol_2_kgC8 = dble(umol_2_kgC ) + real(kind=8), parameter :: Watts_2_Ein8 = dble(Watts_2_Ein ) + real(kind=8), parameter :: Ein_2_Watts8 = dble(Ein_2_Watts ) !---------------------------------------------------------------------------------------! diff --git a/ED/src/memory/detailed_coms.f90 b/ED/src/memory/detailed_coms.f90 new file mode 100644 index 000000000..535fd8a7f --- /dev/null +++ b/ED/src/memory/detailed_coms.f90 @@ -0,0 +1,53 @@ +!==========================================================================================! +!==========================================================================================! +! Module detailed_coms: this module contains variables used to control some ED detailed ! +! output, which can be used for debugging. ! +!------------------------------------------------------------------------------------------! +module detailed_coms + + implicit none + + !---------------------------------------------------------------------------------------! + ! IDETAILED -- This flag controls the possible detailed outputs, mostly used for ! + ! debugging purposes. Notice that this doesn't replace the normal debug- ! + ! ger options, the idea is to provide detailed output to check bad ! + ! assumptions. The options are additive, and the indices below represent ! + ! the different types of output: ! + ! ! + ! 1 -- Detailed budget (every DTLSM) ! + ! 2 -- Detailed photosynthesis (every DTLSM) ! + ! 4 -- Detailed output from the integrator (every HDID) ! + ! 8 -- Thermodynamic bounds for sanity check (every DTLSM) ! + ! 16 -- Daily error stats (which variable caused the time step to shrink) ! + ! 32 -- Allometry parameters, and minimum and maximum sizes ! + ! (two files, only at the beginning) ! + ! ! + ! In case you don't want any detailed output (likely for most runs), set ! + ! IDETAILED to zero. In case you want to generate multiple outputs, add ! + ! the number of the sought options: for example, if you want detailed ! + ! photosynthesis and detailed output from the integrator, set IDETAILED ! + ! to 6 (2 + 4). Any combination of the above outputs is acceptable, al- ! + ! though all but the last produce a sheer amount of txt files, in which ! + ! case you may want to look at variable PATCH_KEEP. It is also a good ! + ! idea to set IVEGT_DYNAMICS to 0 when using the first five outputs. ! + !---------------------------------------------------------------------------------------! + integer :: idetailed + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! PATCH_KEEP -- This option will eliminate all patches except one from the initial- ! + ! isation. This is only used when one of the first five types of ! + ! detailed output is active, otherwise it will be ignored. Options are: ! + ! -2. Keep only the patch with the lowest potential LAI ! + ! -1. Keep only the patch with the highest potential LAI ! + ! 0. Keep all patches. ! + ! > 0. Keep the patch with the provided index. In case the index is ! + ! not valid, the model will crash. ! + !---------------------------------------------------------------------------------------! + integer :: patch_keep + !---------------------------------------------------------------------------------------! + +end module detailed_coms +!==========================================================================================! +!==========================================================================================! diff --git a/ED/src/memory/disturb_coms.f90 b/ED/src/memory/disturb_coms.f90 index 6f2c39050..754c208be 100644 --- a/ED/src/memory/disturb_coms.f90 +++ b/ED/src/memory/disturb_coms.f90 @@ -49,16 +49,22 @@ module disturb_coms ! soil is 1 m, so deeper soils will need to be much drier to allow fires to happen ! ! and often will never allow fires because the threshold may be below the minimum ! ! possible soil moisture. ! - ! 2. Fire will be triggered with enough biomass and the total soil water at the top 75 ! - ! cm falls below a (relative) threshold. ! + ! 2. Fire will be triggered with enough biomass and the total soil water at the top 1.0 ! + ! m falls below a (relative) threshold. ! + ! 3. Similar to 2, but the fire intensity will depend on the soil dryness above the ! + ! threshold (the drier the soil the more extreme the fire is). ! !---------------------------------------------------------------------------------------! integer :: include_fire + !----- Dimensionless parameter controlling speed of fire spread. -----------------------! + real :: fire_parameter + !---------------------------------------------------------------------------------------! ! Anthropogenic disturbance. 1 means that anthropogenic disturbances will be ! ! included, whereas 0 means that it won't. ! !---------------------------------------------------------------------------------------! integer :: ianth_disturb + !---------------------------------------------------------------------------------------! !---------------------------------------------------------------------------------------! @@ -80,6 +86,9 @@ module disturb_coms real :: time2canopy !---------------------------------------------------------------------------------------! + !----- Minimum relative area required for a patch to be created or maintained. ---------! + real :: min_patch_area + !---------------------------------------------------------------------------------------! !----- The prefix for land use disturbance rates. The path and prefix must be included. ! @@ -100,8 +109,6 @@ module disturb_coms !=======================================================================================! ! Patch dynamics variables, to be set in ed_params.f90. ! !---------------------------------------------------------------------------------------! - !----- Minimum relative area required for a patch to be created or maintained. ---------! - real :: min_new_patch_area !----- Only trees above this height create a gap when they fall. -----------------------! real :: treefall_hite_threshold !=======================================================================================! @@ -146,9 +153,6 @@ module disturb_coms ! Fire parameters. ! !---------------------------------------------------------------------------------------! - !----- Dimensionless parameter controlling speed of fire spread. -----------------------! - real :: fire_parameter - !---------------------------------------------------------------------------------------! ! Fire may occur if total equivalent water depth (ground + underground) falls below ! ! this threshold and include_fire is 1. Units: meters. ! diff --git a/ED/src/memory/ed_misc_coms.f90 b/ED/src/memory/ed_misc_coms.f90 index 152c3f87e..81df19b57 100644 --- a/ED/src/memory/ed_misc_coms.f90 +++ b/ED/src/memory/ed_misc_coms.f90 @@ -113,6 +113,23 @@ Module ed_misc_coms + + !---------------------------------------------------------------------------------------! + ! IBIGLEAF -- Do you want to run ED as a 'big leaf' model? ! + ! 0. No, use the standard size- and age-structure (Moorcroft et al. 2001) ! + ! This is the recommended method for most applications. ! + ! 1. 'big leaf' ED: this will have no horizontal or vertical hetero- ! + ! geneities; 1 patch per PFT and 1 cohort per patch; no vertical ! + ! growth, recruits will 'appear' instantaneously at maximum height. ! + ! ! + ! N.B. if you set IBIGLEAF to 1, you MUST turn off the crown model (CROWN_MOD = 0) ! + !---------------------------------------------------------------------------------------! + integer :: ibigleaf + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! ! INTEGRATION_SCHEME -- The biophysics integration scheme. ! ! 0. Euler step. The fastest, but it doesn't estimate ! diff --git a/ED/src/memory/ed_state_vars.f90 b/ED/src/memory/ed_state_vars.f90 index 1764f442a..49ed3cd1e 100644 --- a/ED/src/memory/ed_state_vars.f90 +++ b/ED/src/memory/ed_state_vars.f90 @@ -6,7 +6,6 @@ module ed_state_vars use grid_coms, only: nzg,nzs,ngrids - use c34constants, only : stoma_data,n_stoma_atts use ed_max_dims, only: max_site,n_pft,n_dbh,n_age,n_mort,n_dist_types & ,maxmach,maxgrds, str_len use disturb_coms, only : lutime,num_lu_trans,max_lu_years @@ -114,9 +113,6 @@ module ed_state_vars ! Leaf area index (m2 leaf / m2 ground) real ,pointer,dimension(:) :: lai - ! Wood projected area (m2 wood / m2 ground) - real ,pointer,dimension(:) :: wpa - ! Wood area index (m2 wood / m2 ground) real ,pointer,dimension(:) :: wai @@ -152,6 +148,9 @@ module ed_state_vars ! Leaf temperature (K) real ,pointer,dimension(:) :: leaf_temp + ! Leaf temperature of the previous step (K) + real, pointer,dimension(:) :: leaf_temp_pv + ! Fraction of liquid water on top of leaves (dimensionless) real ,pointer,dimension(:) :: leaf_fliq @@ -167,6 +166,9 @@ module ed_state_vars ! Wood temperature (K) real ,pointer,dimension(:) :: wood_temp + ! Wood temperature at previous step(K) + real ,pointer,dimension(:) :: wood_temp_pv + ! Fraction of liquid water on top of wood (dimensionless) real ,pointer,dimension(:) :: wood_fliq @@ -293,15 +295,7 @@ module ed_state_vars ! Monthly mean Mortality rate [yr-1] (only frost mortality changes...) real , pointer, dimension(:,:) :: mmean_mort_rate - ! This is where you keep the derivatives of the - ! stomatal conductance residual and the old met conditions. - type(stoma_data) ,pointer,dimension(:) :: old_stoma_data - - ! This vector is just for transporting the data into and out - ! of the HDF5 file - real ,pointer,dimension(:,:) :: old_stoma_vector - - ! Transpiration rate, open stomata (mm/s) + ! Transpiration rate, open stomata (kg/m2_leaf/s) real ,pointer,dimension(:) :: Psi_open ! This specifies the index of the deepest soil layer of which the @@ -328,17 +322,6 @@ module ed_state_vars real, pointer, dimension(:) :: light_level_diff real, pointer, dimension(:) :: dmean_light_level_diff real, pointer, dimension(:) :: mmean_light_level_diff - real, pointer, dimension(:) :: beamext_level - real, pointer, dimension(:) :: dmean_beamext_level - real, pointer, dimension(:) :: mmean_beamext_level - real, pointer, dimension(:) :: diffext_level - real, pointer, dimension(:) :: dmean_diffext_level - real, pointer, dimension(:) :: mmean_diffext_level - - ! Light extinction of this cohort, its diurnal and monthly means - real, pointer, dimension(:) :: lambda_light - real, pointer, dimension(:) :: dmean_lambda_light - real, pointer, dimension(:) :: mmean_lambda_light ! Photosynthetically active radiation (PAR) absorbed by the ! cohort leaves(units are W/m2) @@ -421,8 +404,8 @@ module ed_state_vars ! Photosynthesis rate, closed stomata (umol/m2 leaf/s) real ,pointer,dimension(:) :: A_closed - ! Transpiration rate, closed stomata (mm/s) - real ,pointer,dimension(:) :: Psi_closed + ! Transpiration rate, closed stomata (kg/m2_leaf/s) + real ,pointer,dimension(:) :: psi_closed ! Stomatal conductance for water, open stomata (kg_H2O/m2/s) real ,pointer,dimension(:) :: gsw_open @@ -535,9 +518,6 @@ module ed_state_vars ! Leaf area index (m2 leaf / m2 ground) real, pointer,dimension(:) :: lai - ! Wood projected area (m2 wood / m2 ground) - real, pointer,dimension(:) :: wpa - ! Wood area index (m2 wood / m2 ground) real, pointer,dimension(:) :: wai @@ -553,9 +533,6 @@ module ed_state_vars ! Fractional area of the patch real , pointer,dimension(:) :: area - ! Fractional area of the patch (considers lai weighting) - real, pointer,dimension(:) :: laiarea - ! Soil carbon concentration, fast pool (kg/m2) real , pointer,dimension(:) :: fast_soil_C @@ -590,6 +567,10 @@ module ed_state_vars ! Temperature (K) of canopy air real , pointer,dimension(:) :: can_temp + ! Previous step's canopy air temperature + real , pointer,dimension(:) :: can_temp_pv + + ! Water vapor specific humidity (kg/kg) of canopy air real , pointer,dimension(:) :: can_shv @@ -617,11 +598,6 @@ module ed_state_vars real , pointer, dimension(:) :: ggnet real , pointer, dimension(:) :: ggsoil - ! Mean light extinction coefficient, its diurnal and monthly cycle. - real , pointer, dimension(:) :: lambda_light - real , pointer, dimension(:) :: dmean_lambda_light - real , pointer, dimension(:) :: mmean_lambda_light - ! Number of cohorts in the patch integer , pointer,dimension(:) :: cohort_count @@ -699,11 +675,6 @@ module ed_state_vars ! of the canopy (umol/m2 leaf/s). Used by mortality function. real, pointer,dimension(:,:) :: A_o_max ! open stomata real, pointer,dimension(:,:) :: A_c_max ! closed stomata - - ! This will hold the stomatal conductance data from the previous - ! time step corresponding to A_o_max - type(stoma_data), pointer,dimension(:,:) :: old_stoma_data_max - real, pointer,dimension(:,:,:) :: old_stoma_vector_max ! Average daily temperature [K] real , pointer,dimension(:) :: avg_daily_temp @@ -762,6 +733,10 @@ module ed_state_vars ! (J/m2/s) real , pointer,dimension(:) :: ebudget_denseffect + ! Mean change in storage due to pressure change + ! (J/m2/s) + real , pointer,dimension(:) :: ebudget_prsseffect + ! Energy associated with runoff (J/m2/s) real , pointer,dimension(:) :: ebudget_loss2runoff @@ -947,9 +922,6 @@ module ed_state_vars ! coarse woody debris contribution to rh (umol/m2/s) real , pointer,dimension(:) :: cwd_rh - ! Integer flag specifying whether this patch is to be fused - integer , pointer,dimension(:) :: fuse_flag - ! Plant density broken down into size and PFT bins. Used in patch fusion real, pointer,dimension(:,:,:) :: cumlai_profile !(n_pft,ff_nhgt,npatches) @@ -974,6 +946,9 @@ module ed_state_vars ! Last time step successfully completed by integrator. real, pointer,dimension(:) :: htry + ! Last previous time step successfully completed by the integrator + real, pointer,dimension(:) :: hprev + ! Average time step used by the integrator, its daily and monthly mean real, pointer, dimension(:) :: avg_rk4step real, pointer, dimension(:) :: dmean_rk4step @@ -1059,10 +1034,6 @@ module ed_state_vars ! soil layer [kg/m2/s] real,pointer,dimension(:) :: avg_drainage_heat! Average internal energy loss due to water ! drainage through the lower soil layer [kg/m2/s] - - !----- Auxillary Variables (user can modify to view any variable ----------------------! - real,pointer,dimension(:) :: aux ! Auxillary surface variable - real,pointer,dimension(:,:) :: aux_s ! Auxillary soil variable !----- Sensible heat ------------------------------------------------------------------! @@ -1160,8 +1131,6 @@ module ed_state_vars real, pointer,dimension(:,:) :: lai_pft ! Site level mean LAI, grouped by cohort PFT ! [m2/m2] (n_pft,nsites) - real, pointer,dimension(:,:) :: wpa_pft ! Woody Projected Area, grouped by cohort PFT - ! [m2/m2] (n_pft,nsites) real, pointer,dimension(:,:) :: wai_pft ! Woody area index, grouped by cohort PFT ! [m2/m2] (n_pft,nsites) @@ -1333,14 +1302,9 @@ module ed_state_vars real,pointer,dimension(:) :: avg_drainage ! Total drainage real,pointer,dimension(:) :: avg_drainage_heat! Total drainage heat flux - !----- Auxiliary Variables (user can modify to view any variable -----------------------------------------------! - real,pointer,dimension(:) :: aux ! Auxillary surface variable - real,pointer,dimension(:,:) :: aux_s ! Auxillary soil variable - - !---- Polygon LAI, WPA, and WAI ------------------------------------------------------! + !---- Polygon LAI and WAI --------------------------------------------------------------------------------------! real, pointer, dimension(:) :: lai real, pointer, dimension(:) :: avg_lma - real, pointer, dimension(:) :: wpa real, pointer, dimension(:) :: wai !----- Sensible heat -------------------------------------------------------------------------------------------! @@ -1622,14 +1586,9 @@ module ed_state_vars real,pointer,dimension(:) :: avg_drainage ! Total drainage through the soil bottom real,pointer,dimension(:) :: avg_drainage_heat ! Total drainage internal heat loss - !----- Auxillary Variables (user can modify to view any variable --------! - real,pointer,dimension(:) :: aux ! Auxillary surface variable - real,pointer,dimension(:,:) :: aux_s ! Auxillary soil variable - - !----- LAI, WPA, and WAI ------------------------------------------------! + !----- LAI, and WAI -----------------------------------------------------! real,pointer,dimension(:) :: lai real,pointer,dimension(:) :: avg_lma - real,pointer,dimension(:) :: wpa real,pointer,dimension(:) :: wai @@ -1976,7 +1935,6 @@ module ed_state_vars ! averages but they are written at the daily analysis ! !-------------------------------------------------------------------! real, pointer, dimension(:,:) :: lai_pft ! (n_pft , npolygons) - real, pointer, dimension(:,:) :: wpa_pft ! (n_pft , npolygons) real, pointer, dimension(:,:) :: wai_pft ! (n_pft , npolygons) real, pointer, dimension(:,:) :: dmean_gpp_dbh !(n_dbh ,npolygons) @@ -1991,7 +1949,6 @@ module ed_state_vars real, pointer, dimension(:,:) :: mmean_gpp_dbh !(n_dbh ,npolygons) real, pointer, dimension(:,:) :: mmean_lai_pft !(n_pft ,npolygons) - real, pointer, dimension(:,:) :: mmean_wpa_pft !(n_pft ,npolygons) real, pointer, dimension(:,:) :: mmean_wai_pft !(n_pft ,npolygons) !-------------------------------------------------------------------! @@ -2227,7 +2184,7 @@ subroutine allocate_edglobals(ngrids) num_var = 0 allocate(vt_info(maxvars,ngrids)) - vt_info(:,:)%first=.true. + vt_info(:,:)%vector_allocated = .false. ! Initialize the global offsets @@ -2317,7 +2274,6 @@ subroutine allocate_edtype(cgrid,npolygons) allocate(cgrid%lai (npolygons)) allocate(cgrid%avg_lma(npolygons)) - allocate(cgrid%wpa (npolygons)) allocate(cgrid%wai (npolygons)) ! Fast time flux diagnostics @@ -2336,8 +2292,6 @@ subroutine allocate_edtype(cgrid,npolygons) allocate(cgrid%avg_runoff (npolygons)) allocate(cgrid%avg_drainage (npolygons)) allocate(cgrid%avg_drainage_heat (npolygons)) - allocate(cgrid%aux (npolygons)) - allocate(cgrid%aux_s (nzg,npolygons)) allocate(cgrid%avg_rshort_gnd (npolygons)) allocate(cgrid%avg_rlong_gnd (npolygons)) allocate(cgrid%avg_ustar (npolygons)) @@ -2491,7 +2445,6 @@ subroutine allocate_edtype(cgrid,npolygons) allocate(cgrid%avg_rlongup (npolygons)) allocate(cgrid%lai_pft (n_pft ,npolygons)) - allocate(cgrid%wpa_pft (n_pft ,npolygons)) allocate(cgrid%wai_pft (n_pft ,npolygons)) allocate(cgrid%workload (13 ,npolygons)) @@ -2636,7 +2589,6 @@ subroutine allocate_edtype(cgrid,npolygons) allocate(cgrid%mmean_fsn ( npolygons)) allocate(cgrid%mmean_gpp_dbh (n_dbh ,npolygons)) allocate(cgrid%mmean_lai_pft (n_pft ,npolygons)) - allocate(cgrid%mmean_wpa_pft (n_pft ,npolygons)) allocate(cgrid%mmean_wai_pft (n_pft ,npolygons)) allocate(cgrid%mmean_can_temp ( npolygons)) allocate(cgrid%mmean_can_shv ( npolygons)) @@ -2836,7 +2788,6 @@ subroutine allocate_polygontype(cpoly,nsites) allocate(cpoly%probharv_secondary(n_pft,nsites)) allocate(cpoly%lai_pft(n_pft,nsites)) - allocate(cpoly%wpa_pft(n_pft,nsites)) allocate(cpoly%wai_pft(n_pft,nsites)) allocate(cpoly%TCI(nsites)) @@ -2895,7 +2846,6 @@ subroutine allocate_polygontype(cpoly,nsites) allocate(cpoly%lai (nsites)) allocate(cpoly%avg_lma(nsites)) - allocate(cpoly%wpa (nsites)) allocate(cpoly%wai (nsites)) ! Fast time flux diagnostics ! --------------------------------------------- @@ -2914,8 +2864,6 @@ subroutine allocate_polygontype(cpoly,nsites) allocate(cpoly%avg_runoff (nsites)) allocate(cpoly%avg_drainage (nsites)) allocate(cpoly%avg_drainage_heat (nsites)) - allocate(cpoly%aux (nsites)) - allocate(cpoly%aux_s (nzg,nsites)) allocate(cpoly%avg_rshort_gnd (nsites)) allocate(cpoly%avg_rlong_gnd (nsites)) allocate(cpoly%avg_ustar (nsites)) @@ -3029,12 +2977,10 @@ subroutine allocate_sitetype(csite,npatches) end do allocate(csite%lai(npatches)) - allocate(csite%wpa(npatches)) allocate(csite%wai(npatches)) allocate(csite%dist_type(npatches)) allocate(csite%age(npatches)) allocate(csite%area(npatches)) - allocate(csite%laiarea(npatches)) allocate(csite%fast_soil_C(npatches)) allocate(csite%slow_soil_C(npatches)) allocate(csite%structural_soil_C(npatches)) @@ -3046,6 +2992,7 @@ subroutine allocate_sitetype(csite,npatches) allocate(csite%plantation(npatches)) allocate(csite%can_theiv(npatches)) allocate(csite%can_temp(npatches)) + allocate(csite%can_temp_pv(npatches)) allocate(csite%can_shv(npatches)) allocate(csite%can_co2(npatches)) allocate(csite%can_rhos(npatches)) @@ -3057,7 +3004,6 @@ subroutine allocate_sitetype(csite,npatches) allocate(csite%ggveg(npatches)) allocate(csite%ggnet(npatches)) allocate(csite%ggsoil(npatches)) - allocate(csite%lambda_light(npatches)) allocate(csite%cohort_count(npatches)) allocate(csite%pname(npatches)) @@ -3086,9 +3032,6 @@ subroutine allocate_sitetype(csite,npatches) allocate(csite%A_o_max(n_pft,npatches)) allocate(csite%A_c_max(n_pft,npatches)) - allocate(csite%old_stoma_data_max(n_pft,npatches)) - allocate(csite%old_stoma_vector_max(n_stoma_atts,n_pft,npatches)) - allocate(csite%avg_daily_temp(npatches)) allocate(csite%avg_monthly_gndwater(npatches)) allocate(csite%mean_rh(npatches)) @@ -3102,6 +3045,7 @@ subroutine allocate_sitetype(csite,npatches) allocate(csite%wbudget_residual(npatches)) allocate(csite%ebudget_loss2atm(npatches)) allocate(csite%ebudget_denseffect(npatches)) + allocate(csite%ebudget_prsseffect(npatches)) allocate(csite%ebudget_loss2runoff(npatches)) allocate(csite%ebudget_loss2drainage(npatches)) allocate(csite%ebudget_netrad(npatches)) @@ -3155,7 +3099,6 @@ subroutine allocate_sitetype(csite,npatches) allocate(csite%f_decomp(npatches)) allocate(csite%rh(npatches)) allocate(csite%cwd_rh(npatches)) - allocate(csite%fuse_flag(npatches)) allocate(csite%cumlai_profile(n_pft,ff_nhgt,npatches)) allocate(csite%plant_ag_biomass(npatches)) @@ -3166,6 +3109,8 @@ subroutine allocate_sitetype(csite,npatches) allocate(csite%mean_qrunoff(npatches)) allocate(csite%htry (npatches)) + allocate(csite%hprev (npatches)) + allocate(csite%avg_rk4step(npatches)) allocate(csite%avg_available_water(npatches)) @@ -3214,8 +3159,6 @@ subroutine allocate_sitetype(csite,npatches) allocate(csite%avg_runoff (npatches)) allocate(csite%avg_drainage (npatches)) allocate(csite%avg_drainage_heat (npatches)) - allocate(csite%aux (npatches)) - allocate(csite%aux_s (nzg,npatches)) allocate(csite%avg_sensible_lc (npatches)) allocate(csite%avg_sensible_wc (npatches)) allocate(csite%avg_qwshed_vg (npatches)) @@ -3253,7 +3196,6 @@ subroutine allocate_sitetype(csite,npatches) if (imoutput > 0 .or. idoutput > 0 .or. iqoutput > 0) then allocate(csite%dmean_rk4step (npatches)) - allocate(csite%dmean_lambda_light (npatches)) allocate(csite%dmean_co2_residual (npatches)) allocate(csite%dmean_energy_residual (npatches)) allocate(csite%dmean_water_residual (npatches)) @@ -3266,7 +3208,6 @@ subroutine allocate_sitetype(csite,npatches) end if if (imoutput > 0 .or. iqoutput > 0) then allocate(csite%mmean_rk4step (npatches)) - allocate(csite%mmean_lambda_light (npatches)) allocate(csite%mmean_co2_residual (npatches)) allocate(csite%mmean_energy_residual (npatches)) allocate(csite%mmean_water_residual (npatches)) @@ -3324,7 +3265,6 @@ subroutine allocate_patchtype(cpatch,ncohorts) allocate(cpatch%broot(ncohorts)) allocate(cpatch%bsapwood(ncohorts)) allocate(cpatch%lai(ncohorts)) - allocate(cpatch%wpa(ncohorts)) allocate(cpatch%wai(ncohorts)) allocate(cpatch%crown_area(ncohorts)) allocate(cpatch%leaf_resolvable(ncohorts)) @@ -3335,11 +3275,13 @@ subroutine allocate_patchtype(cpatch,ncohorts) allocate(cpatch%cbr_bar(ncohorts)) allocate(cpatch%leaf_energy(ncohorts)) allocate(cpatch%leaf_temp (ncohorts)) + allocate(cpatch%leaf_temp_pv(ncohorts)) allocate(cpatch%leaf_hcap (ncohorts)) allocate(cpatch%leaf_fliq (ncohorts)) allocate(cpatch%leaf_water (ncohorts)) allocate(cpatch%wood_energy(ncohorts)) allocate(cpatch%wood_temp (ncohorts)) + allocate(cpatch%wood_temp_pv (ncohorts)) allocate(cpatch%wood_hcap (ncohorts)) allocate(cpatch%wood_fliq (ncohorts)) allocate(cpatch%wood_water (ncohorts)) @@ -3376,10 +3318,6 @@ subroutine allocate_patchtype(cpatch,ncohorts) allocate(cpatch%monthly_dndt(ncohorts)) allocate(cpatch%mort_rate(n_mort,ncohorts)) - ! Soon to be replaced - allocate(cpatch%old_stoma_data(ncohorts)) - allocate(cpatch%old_stoma_vector(n_stoma_atts,ncohorts)) - allocate(cpatch%Psi_open(ncohorts)) allocate(cpatch%krdepth(ncohorts)) allocate(cpatch%first_census(ncohorts)) @@ -3387,9 +3325,6 @@ subroutine allocate_patchtype(cpatch,ncohorts) allocate(cpatch%light_level(ncohorts)) allocate(cpatch%light_level_beam(ncohorts)) allocate(cpatch%light_level_diff(ncohorts)) - allocate(cpatch%beamext_level(ncohorts)) - allocate(cpatch%diffext_level(ncohorts)) - allocate(cpatch%lambda_light(ncohorts)) allocate(cpatch%par_l(ncohorts)) allocate(cpatch%par_l_beam(ncohorts)) allocate(cpatch%par_l_diffuse(ncohorts)) @@ -3439,9 +3374,6 @@ subroutine allocate_patchtype(cpatch,ncohorts) allocate(cpatch%dmean_light_level(ncohorts)) allocate(cpatch%dmean_light_level_beam(ncohorts)) allocate(cpatch%dmean_light_level_diff(ncohorts)) - allocate(cpatch%dmean_beamext_level(ncohorts)) - allocate(cpatch%dmean_diffext_level(ncohorts)) - allocate(cpatch%dmean_lambda_light(ncohorts)) allocate(cpatch%dmean_fs_open(ncohorts)) allocate(cpatch%dmean_fsw(ncohorts)) allocate(cpatch%dmean_fsn(ncohorts)) @@ -3470,9 +3402,6 @@ subroutine allocate_patchtype(cpatch,ncohorts) allocate(cpatch%mmean_light_level(ncohorts)) allocate(cpatch%mmean_light_level_beam(ncohorts)) allocate(cpatch%mmean_light_level_diff(ncohorts)) - allocate(cpatch%mmean_beamext_level(ncohorts)) - allocate(cpatch%mmean_diffext_level(ncohorts)) - allocate(cpatch%mmean_lambda_light(ncohorts)) allocate(cpatch%mmean_fs_open(ncohorts)) allocate(cpatch%mmean_fsw(ncohorts)) allocate(cpatch%mmean_fsn(ncohorts)) @@ -3587,7 +3516,6 @@ subroutine nullify_edtype(cgrid) nullify(cgrid%lai ) nullify(cgrid%avg_lma ) - nullify(cgrid%wpa ) nullify(cgrid%wai ) ! Fast time flux diagnostics @@ -3606,8 +3534,6 @@ subroutine nullify_edtype(cgrid) nullify(cgrid%avg_runoff ) nullify(cgrid%avg_drainage ) nullify(cgrid%avg_drainage_heat ) - nullify(cgrid%aux ) - nullify(cgrid%aux_s ) nullify(cgrid%avg_rshort_gnd ) nullify(cgrid%avg_rlong_gnd ) nullify(cgrid%avg_ustar ) @@ -3835,7 +3761,6 @@ subroutine nullify_edtype(cgrid) nullify(cgrid%dmean_energy_residual ) nullify(cgrid%dmean_water_residual ) nullify(cgrid%lai_pft ) - nullify(cgrid%wpa_pft ) nullify(cgrid%wai_pft ) nullify(cgrid%mmean_ustar ) nullify(cgrid%mmean_tstar ) @@ -3878,7 +3803,6 @@ subroutine nullify_edtype(cgrid) nullify(cgrid%mmean_vleaf_resp ) nullify(cgrid%mmean_gpp_dbh ) nullify(cgrid%mmean_lai_pft ) - nullify(cgrid%mmean_wpa_pft ) nullify(cgrid%mmean_wai_pft ) nullify(cgrid%mmean_can_temp ) nullify(cgrid%mmean_can_shv ) @@ -4063,7 +3987,6 @@ subroutine nullify_polygontype(cpoly) nullify(cpoly%lai_pft) - nullify(cpoly%wpa_pft) nullify(cpoly%wai_pft) nullify(cpoly%TCI) @@ -4119,7 +4042,6 @@ subroutine nullify_polygontype(cpoly) nullify(cpoly%avg_lma ) nullify(cpoly%daylight) nullify(cpoly%lai ) - nullify(cpoly%wpa ) nullify(cpoly%wai ) ! Fast time flux diagnostics @@ -4138,8 +4060,6 @@ subroutine nullify_polygontype(cpoly) nullify(cpoly%avg_runoff ) nullify(cpoly%avg_drainage ) nullify(cpoly%avg_drainage_heat ) - nullify(cpoly%aux ) - nullify(cpoly%aux_s ) nullify(cpoly%avg_rshort_gnd ) nullify(cpoly%avg_rlong_gnd ) nullify(cpoly%avg_ustar ) @@ -4242,7 +4162,6 @@ subroutine nullify_sitetype(csite) nullify(csite%dist_type) nullify(csite%age) nullify(csite%area) - nullify(csite%laiarea) nullify(csite%fast_soil_C) nullify(csite%slow_soil_C) nullify(csite%structural_soil_C) @@ -4256,6 +4175,7 @@ subroutine nullify_sitetype(csite) nullify(csite%cohort_count) nullify(csite%can_theiv) nullify(csite%can_temp) + nullify(csite%can_temp_pv) nullify(csite%can_shv) nullify(csite%can_co2) nullify(csite%can_rhos) @@ -4267,11 +4187,7 @@ subroutine nullify_sitetype(csite) nullify(csite%ggveg) nullify(csite%ggnet) nullify(csite%ggsoil) - nullify(csite%lambda_light) - nullify(csite%dmean_lambda_light) - nullify(csite%mmean_lambda_light) nullify(csite%lai) - nullify(csite%wpa) nullify(csite%wai) nullify(csite%sfcwater_mass) @@ -4298,8 +4214,6 @@ subroutine nullify_sitetype(csite) nullify(csite%par_l_diffuse_max) nullify(csite%A_o_max) nullify(csite%A_c_max) - nullify(csite%old_stoma_data_max) - nullify(csite%old_stoma_vector_max) nullify(csite%avg_daily_temp) nullify(csite%avg_monthly_gndwater) nullify(csite%mean_rh) @@ -4325,6 +4239,7 @@ subroutine nullify_sitetype(csite) nullify(csite%wbudget_residual) nullify(csite%ebudget_loss2atm) nullify(csite%ebudget_denseffect) + nullify(csite%ebudget_prsseffect) nullify(csite%ebudget_loss2runoff) nullify(csite%ebudget_loss2drainage) nullify(csite%ebudget_netrad) @@ -4382,7 +4297,6 @@ subroutine nullify_sitetype(csite) nullify(csite%f_decomp) nullify(csite%rh) nullify(csite%cwd_rh) - nullify(csite%fuse_flag) nullify(csite%cumlai_profile) nullify(csite%plant_ag_biomass) @@ -4393,6 +4307,7 @@ subroutine nullify_sitetype(csite) nullify(csite%mean_qrunoff) nullify(csite%htry) + nullify(csite%hprev) nullify(csite%avg_rk4step) nullify(csite%dmean_rk4step) nullify(csite%mmean_rk4step) @@ -4444,8 +4359,6 @@ subroutine nullify_sitetype(csite) nullify(csite%avg_runoff ) nullify(csite%avg_drainage ) nullify(csite%avg_drainage_heat ) - nullify(csite%aux ) - nullify(csite%aux_s ) nullify(csite%avg_sensible_lc ) nullify(csite%avg_sensible_wc ) nullify(csite%avg_qwshed_vg ) @@ -4520,7 +4433,6 @@ subroutine nullify_patchtype(cpatch) nullify(cpatch%broot) nullify(cpatch%bsapwood) nullify(cpatch%lai) - nullify(cpatch%wpa) nullify(cpatch%wai) nullify(cpatch%crown_area) nullify(cpatch%leaf_resolvable) @@ -4532,11 +4444,13 @@ subroutine nullify_patchtype(cpatch) nullify(cpatch%mmean_cb) nullify(cpatch%leaf_energy) nullify(cpatch%leaf_temp ) + nullify(cpatch%leaf_temp_pv) nullify(cpatch%leaf_hcap ) nullify(cpatch%leaf_fliq ) nullify(cpatch%leaf_water ) nullify(cpatch%wood_energy) nullify(cpatch%wood_temp ) + nullify(cpatch%wood_temp_pv ) nullify(cpatch%wood_hcap ) nullify(cpatch%wood_fliq ) nullify(cpatch%wood_water ) @@ -4596,8 +4510,6 @@ subroutine nullify_patchtype(cpatch) nullify(cpatch%monthly_dndt) nullify(cpatch%mort_rate) nullify(cpatch%mmean_mort_rate) - nullify(cpatch%old_stoma_data) - nullify(cpatch%old_stoma_vector) nullify(cpatch%Psi_open) nullify(cpatch%krdepth) nullify(cpatch%first_census) @@ -4611,15 +4523,6 @@ subroutine nullify_patchtype(cpatch) nullify(cpatch%light_level_diff) nullify(cpatch%dmean_light_level_diff) nullify(cpatch%mmean_light_level_diff) - nullify(cpatch%beamext_level) - nullify(cpatch%dmean_beamext_level) - nullify(cpatch%mmean_beamext_level) - nullify(cpatch%diffext_level) - nullify(cpatch%dmean_diffext_level) - nullify(cpatch%mmean_diffext_level) - nullify(cpatch%lambda_light) - nullify(cpatch%dmean_lambda_light) - nullify(cpatch%mmean_lambda_light) nullify(cpatch%dmean_par_l) nullify(cpatch%dmean_par_l_beam) nullify(cpatch%dmean_par_l_diff) @@ -4715,8 +4618,8 @@ subroutine deallocate_edtype(cgrid) implicit none type(edtype),target :: cgrid + integer :: ipy - if(associated(cgrid%polygon )) deallocate(cgrid%polygon ) if(associated(cgrid%lat )) deallocate(cgrid%lat ) if(associated(cgrid%lon )) deallocate(cgrid%lon ) if(associated(cgrid%xatm )) deallocate(cgrid%xatm ) @@ -4770,7 +4673,6 @@ subroutine deallocate_edtype(cgrid) if(associated(cgrid%lai )) deallocate(cgrid%lai ) if(associated(cgrid%avg_lma )) deallocate(cgrid%avg_lma ) - if(associated(cgrid%wpa )) deallocate(cgrid%wpa ) if(associated(cgrid%wai )) deallocate(cgrid%wai ) ! Fast time flux diagnostics @@ -4789,8 +4691,6 @@ subroutine deallocate_edtype(cgrid) if(associated(cgrid%avg_runoff )) deallocate(cgrid%avg_runoff ) if(associated(cgrid%avg_drainage )) deallocate(cgrid%avg_drainage ) if(associated(cgrid%avg_drainage_heat )) deallocate(cgrid%avg_drainage_heat ) - if(associated(cgrid%aux )) deallocate(cgrid%aux ) - if(associated(cgrid%aux_s )) deallocate(cgrid%aux_s ) if(associated(cgrid%avg_rshort_gnd )) deallocate(cgrid%avg_rshort_gnd ) if(associated(cgrid%avg_rlong_gnd )) deallocate(cgrid%avg_rlong_gnd ) if(associated(cgrid%avg_ustar )) deallocate(cgrid%avg_ustar ) @@ -5033,7 +4933,6 @@ subroutine deallocate_edtype(cgrid) if(associated(cgrid%dmean_water_residual )) deallocate(cgrid%dmean_water_residual ) if(associated(cgrid%lai_pft )) deallocate(cgrid%lai_pft ) - if(associated(cgrid%wpa_pft )) deallocate(cgrid%wpa_pft ) if(associated(cgrid%wai_pft )) deallocate(cgrid%wai_pft ) if(associated(cgrid%mmean_gpp )) deallocate(cgrid%mmean_gpp ) if(associated(cgrid%mmean_nppleaf )) deallocate(cgrid%mmean_nppleaf ) @@ -5076,7 +4975,6 @@ subroutine deallocate_edtype(cgrid) if(associated(cgrid%mmean_vleaf_resp )) deallocate(cgrid%mmean_vleaf_resp ) if(associated(cgrid%mmean_gpp_dbh )) deallocate(cgrid%mmean_gpp_dbh ) if(associated(cgrid%mmean_lai_pft )) deallocate(cgrid%mmean_lai_pft ) - if(associated(cgrid%mmean_wpa_pft )) deallocate(cgrid%mmean_wpa_pft ) if(associated(cgrid%mmean_wai_pft )) deallocate(cgrid%mmean_wai_pft ) if(associated(cgrid%mmean_can_temp )) deallocate(cgrid%mmean_can_temp ) if(associated(cgrid%mmean_can_shv )) deallocate(cgrid%mmean_can_shv ) @@ -5224,6 +5122,12 @@ subroutine deallocate_edtype(cgrid) if(associated(cgrid%qmsqu_vapor_wc )) deallocate(cgrid%qmsqu_vapor_wc ) if(associated(cgrid%qmsqu_vapor_gc )) deallocate(cgrid%qmsqu_vapor_gc ) + do ipy=1,cgrid%npolygons + call deallocate_polygontype(cgrid%polygon(ipy)) + end do + if(associated(cgrid%polygon )) deallocate(cgrid%polygon ) + + return end subroutine deallocate_edtype !============================================================================! @@ -5240,11 +5144,11 @@ subroutine deallocate_polygontype(cpoly) implicit none type(polygontype),target :: cpoly + integer :: isi if(associated(cpoly%sipa_id )) deallocate(cpoly%sipa_id ) if(associated(cpoly%sipa_n )) deallocate(cpoly%sipa_n ) if(associated(cpoly%patch_count )) deallocate(cpoly%patch_count ) - if(associated(cpoly%site )) deallocate(cpoly%site ) if(associated(cpoly%sitenum )) deallocate(cpoly%sitenum ) if(associated(cpoly%lsl )) deallocate(cpoly%lsl ) @@ -5263,11 +5167,10 @@ subroutine deallocate_polygontype(cpoly) if(associated(cpoly%lai_pft )) deallocate(cpoly%lai_pft ) - if(associated(cpoly%wpa_pft )) deallocate(cpoly%wpa_pft ) if(associated(cpoly%wai_pft )) deallocate(cpoly%wai_pft ) if(associated(cpoly%TCI )) deallocate(cpoly%TCI ) - if(associated(cpoly%pptweight )) deallocate(cpoly%pptweight ) + if(associated(cpoly%pptweight )) deallocate(cpoly%pptweight ) if(associated(cpoly%lsl )) deallocate(cpoly%lsl ) if(associated(cpoly%hydro_next )) deallocate(cpoly%hydro_next ) if(associated(cpoly%hydro_prev )) deallocate(cpoly%hydro_prev ) @@ -5320,8 +5223,7 @@ subroutine deallocate_polygontype(cpoly) if(associated(cpoly%lai )) deallocate(cpoly%lai ) if(associated(cpoly%avg_lma )) deallocate(cpoly%avg_lma ) - if(associated(cpoly%wpa )) deallocate(cpoly%wpa ) - if(associated(cpoly%wai )) deallocate(cpoly%wai ) + if(associated(cpoly%wai )) deallocate(cpoly%wai ) ! Fast time flux diagnostics ! --------------------------------------------- @@ -5339,8 +5241,6 @@ subroutine deallocate_polygontype(cpoly) if(associated(cpoly%avg_runoff )) deallocate(cpoly%avg_runoff ) if(associated(cpoly%avg_drainage )) deallocate(cpoly%avg_drainage ) if(associated(cpoly%avg_drainage_heat )) deallocate(cpoly%avg_drainage_heat ) - if(associated(cpoly%aux )) deallocate(cpoly%aux ) - if(associated(cpoly%aux_s )) deallocate(cpoly%aux_s ) if(associated(cpoly%avg_rshort_gnd )) deallocate(cpoly%avg_rshort_gnd ) if(associated(cpoly%avg_rlong_gnd )) deallocate(cpoly%avg_rlong_gnd ) if(associated(cpoly%avg_ustar )) deallocate(cpoly%avg_ustar ) @@ -5418,6 +5318,12 @@ subroutine deallocate_polygontype(cpoly) if(associated(cpoly%mmean_energy_residual )) deallocate(cpoly%mmean_energy_residual ) if(associated(cpoly%mmean_water_residual )) deallocate(cpoly%mmean_water_residual ) + do isi = 1, cpoly%nsites + call deallocate_sitetype(cpoly%site(isi)) + end do + if(associated(cpoly%site )) deallocate(cpoly%site ) + + return end subroutine deallocate_polygontype !============================================================================! @@ -5442,7 +5348,6 @@ subroutine deallocate_sitetype(csite) if(associated(csite%dist_type )) deallocate(csite%dist_type ) if(associated(csite%age )) deallocate(csite%age ) if(associated(csite%area )) deallocate(csite%area ) - if(associated(csite%laiarea )) deallocate(csite%laiarea ) if(associated(csite%fast_soil_C )) deallocate(csite%fast_soil_C ) if(associated(csite%slow_soil_C )) deallocate(csite%slow_soil_C ) if(associated(csite%structural_soil_C )) deallocate(csite%structural_soil_C ) @@ -5456,6 +5361,7 @@ subroutine deallocate_sitetype(csite) if(associated(csite%cohort_count )) deallocate(csite%cohort_count ) if(associated(csite%can_theiv )) deallocate(csite%can_theiv ) if(associated(csite%can_temp )) deallocate(csite%can_temp ) + if(associated(csite%can_temp_pv )) deallocate(csite%can_temp_pv ) if(associated(csite%can_shv )) deallocate(csite%can_shv ) if(associated(csite%can_co2 )) deallocate(csite%can_co2 ) if(associated(csite%can_rhos )) deallocate(csite%can_rhos ) @@ -5467,11 +5373,7 @@ subroutine deallocate_sitetype(csite) if(associated(csite%ggveg )) deallocate(csite%ggveg ) if(associated(csite%ggnet )) deallocate(csite%ggnet ) if(associated(csite%ggsoil )) deallocate(csite%ggsoil ) - if(associated(csite%lambda_light )) deallocate(csite%lambda_light ) - if(associated(csite%dmean_lambda_light )) deallocate(csite%dmean_lambda_light ) - if(associated(csite%mmean_lambda_light )) deallocate(csite%mmean_lambda_light ) if(associated(csite%lai )) deallocate(csite%lai ) - if(associated(csite%wpa )) deallocate(csite%wpa ) if(associated(csite%wai )) deallocate(csite%wai ) if(associated(csite%sfcwater_mass )) deallocate(csite%sfcwater_mass ) @@ -5499,9 +5401,6 @@ subroutine deallocate_sitetype(csite) if(associated(csite%A_o_max )) deallocate(csite%A_o_max ) if(associated(csite%A_c_max )) deallocate(csite%A_c_max ) - if(associated(csite%old_stoma_data_max )) deallocate(csite%old_stoma_data_max ) - if(associated(csite%old_stoma_vector_max )) deallocate(csite%old_stoma_vector_max ) - if(associated(csite%avg_daily_temp )) deallocate(csite%avg_daily_temp ) if(associated(csite%avg_monthly_gndwater )) deallocate(csite%avg_monthly_gndwater ) if(associated(csite%mean_rh )) deallocate(csite%mean_rh ) @@ -5527,6 +5426,7 @@ subroutine deallocate_sitetype(csite) if(associated(csite%wbudget_residual )) deallocate(csite%wbudget_residual ) if(associated(csite%ebudget_loss2atm )) deallocate(csite%ebudget_loss2atm ) if(associated(csite%ebudget_denseffect )) deallocate(csite%ebudget_denseffect ) + if(associated(csite%ebudget_prsseffect )) deallocate(csite%ebudget_prsseffect ) if(associated(csite%ebudget_loss2runoff )) deallocate(csite%ebudget_loss2runoff ) if(associated(csite%ebudget_loss2drainage )) deallocate(csite%ebudget_loss2drainage ) if(associated(csite%ebudget_netrad )) deallocate(csite%ebudget_netrad ) @@ -5584,7 +5484,6 @@ subroutine deallocate_sitetype(csite) if(associated(csite%f_decomp )) deallocate(csite%f_decomp ) if(associated(csite%rh )) deallocate(csite%rh ) if(associated(csite%cwd_rh )) deallocate(csite%cwd_rh ) - if(associated(csite%fuse_flag )) deallocate(csite%fuse_flag ) if(associated(csite%cumlai_profile )) deallocate(csite%cumlai_profile ) if(associated(csite%plant_ag_biomass )) deallocate(csite%plant_ag_biomass ) @@ -5595,6 +5494,7 @@ subroutine deallocate_sitetype(csite) if(associated(csite%mean_qrunoff )) deallocate(csite%mean_qrunoff ) if(associated(csite%htry )) deallocate(csite%htry ) + if(associated(csite%hprev )) deallocate(csite%hprev ) if(associated(csite%avg_rk4step )) deallocate(csite%avg_rk4step ) if(associated(csite%dmean_rk4step )) deallocate(csite%dmean_rk4step ) if(associated(csite%mmean_rk4step )) deallocate(csite%mmean_rk4step ) @@ -5643,8 +5543,6 @@ subroutine deallocate_sitetype(csite) if(associated(csite%avg_runoff )) deallocate(csite%avg_runoff ) if(associated(csite%avg_drainage )) deallocate(csite%avg_drainage ) if(associated(csite%avg_drainage_heat )) deallocate(csite%avg_drainage_heat ) - if(associated(csite%aux )) deallocate(csite%aux ) - if(associated(csite%aux_s )) deallocate(csite%aux_s ) if(associated(csite%avg_sensible_lc )) deallocate(csite%avg_sensible_lc ) if(associated(csite%avg_sensible_wc )) deallocate(csite%avg_sensible_wc ) if(associated(csite%avg_qwshed_vg )) deallocate(csite%avg_qwshed_vg ) @@ -5723,7 +5621,6 @@ subroutine deallocate_patchtype(cpatch) if(associated(cpatch%broot)) deallocate(cpatch%broot) if(associated(cpatch%bsapwood)) deallocate(cpatch%bsapwood) if(associated(cpatch%lai)) deallocate(cpatch%lai) - if(associated(cpatch%wpa)) deallocate(cpatch%wpa) if(associated(cpatch%wai)) deallocate(cpatch%wai) if(associated(cpatch%crown_area)) deallocate(cpatch%crown_area) if(associated(cpatch%leaf_resolvable)) deallocate(cpatch%leaf_resolvable) @@ -5735,11 +5632,13 @@ subroutine deallocate_patchtype(cpatch) if(associated(cpatch%mmean_cb)) deallocate(cpatch%mmean_cb) if(associated(cpatch%leaf_energy)) deallocate(cpatch%leaf_energy) if(associated(cpatch%leaf_temp )) deallocate(cpatch%leaf_temp ) + if(associated(cpatch%leaf_temp_pv )) deallocate(cpatch%leaf_temp_pv ) if(associated(cpatch%leaf_hcap )) deallocate(cpatch%leaf_hcap ) if(associated(cpatch%leaf_fliq )) deallocate(cpatch%leaf_fliq ) if(associated(cpatch%leaf_water )) deallocate(cpatch%leaf_water ) if(associated(cpatch%wood_energy)) deallocate(cpatch%wood_energy) if(associated(cpatch%wood_temp )) deallocate(cpatch%wood_temp ) + if(associated(cpatch%wood_temp_pv )) deallocate(cpatch%wood_temp_pv ) if(associated(cpatch%wood_hcap )) deallocate(cpatch%wood_hcap ) if(associated(cpatch%wood_fliq )) deallocate(cpatch%wood_fliq ) if(associated(cpatch%wood_water )) deallocate(cpatch%wood_water ) @@ -5800,8 +5699,6 @@ subroutine deallocate_patchtype(cpatch) if(associated(cpatch%mort_rate)) deallocate(cpatch%mort_rate) if(associated(cpatch%mmean_mort_rate)) deallocate(cpatch%mmean_mort_rate) - if(associated(cpatch%old_stoma_data)) deallocate(cpatch%old_stoma_data) - if(associated(cpatch%old_stoma_vector)) deallocate(cpatch%old_stoma_vector) if(associated(cpatch%Psi_open)) deallocate(cpatch%Psi_open) if(associated(cpatch%krdepth)) deallocate(cpatch%krdepth) if(associated(cpatch%first_census)) deallocate(cpatch%first_census) @@ -5815,15 +5712,6 @@ subroutine deallocate_patchtype(cpatch) if(associated(cpatch%light_level_diff)) deallocate(cpatch%light_level_diff) if(associated(cpatch%dmean_light_level_diff)) deallocate(cpatch%dmean_light_level_diff) if(associated(cpatch%mmean_light_level_diff)) deallocate(cpatch%mmean_light_level_diff) - if(associated(cpatch%beamext_level)) deallocate(cpatch%beamext_level) - if(associated(cpatch%dmean_beamext_level)) deallocate(cpatch%dmean_beamext_level) - if(associated(cpatch%mmean_beamext_level)) deallocate(cpatch%mmean_beamext_level) - if(associated(cpatch%diffext_level)) deallocate(cpatch%diffext_level) - if(associated(cpatch%dmean_diffext_level)) deallocate(cpatch%dmean_diffext_level) - if(associated(cpatch%mmean_diffext_level)) deallocate(cpatch%mmean_diffext_level) - if(associated(cpatch%lambda_light)) deallocate(cpatch%lambda_light) - if(associated(cpatch%dmean_lambda_light)) deallocate(cpatch%dmean_lambda_light) - if(associated(cpatch%mmean_lambda_light)) deallocate(cpatch%mmean_lambda_light) if(associated(cpatch%par_l)) deallocate(cpatch%par_l) if(associated(cpatch%par_l_beam)) deallocate(cpatch%par_l_beam) if(associated(cpatch%par_l_diffuse)) deallocate(cpatch%par_l_diffuse) @@ -5928,8 +5816,6 @@ subroutine copy_sitetype(isite,osite,ipaa,ipaz,opaa,opaz) integer , intent(in) :: opaa ! First output patch index integer , intent(in) :: opaz ! Last output patch index !----- Local variables. -------------------------------------------------------------! - type(stoma_data), pointer :: osdi ! Old stomate data - input patch - type(stoma_data), pointer :: osdo ! Old stomate data - output patch integer :: ipa ! Counter for the input site patches integer :: opa ! Counter for the output site patches integer :: k ! Vertical layer counter @@ -5979,6 +5865,7 @@ subroutine copy_sitetype(isite,osite,ipaa,ipaz,opaa,opaz) osite%cohort_count(opa) = isite%cohort_count(ipa) osite%can_theiv(opa) = isite%can_theiv(ipa) osite%can_temp(opa) = isite%can_temp(ipa) + osite%can_temp_pv(opa) = isite%can_temp_pv(ipa) osite%can_shv(opa) = isite%can_shv(ipa) osite%can_co2(opa) = isite%can_co2(ipa) osite%can_rhos(opa) = isite%can_rhos(ipa) @@ -5990,9 +5877,7 @@ subroutine copy_sitetype(isite,osite,ipaa,ipaz,opaa,opaz) osite%ggveg(opa) = isite%ggveg(ipa) osite%ggnet(opa) = isite%ggnet(ipa) osite%ggsoil(opa) = isite%ggsoil(ipa) - osite%lambda_light(opa) = isite%lambda_light(ipa) osite%lai(opa) = isite%lai(ipa) - osite%wpa(opa) = isite%wpa(ipa) osite%wai(opa) = isite%wai(ipa) osite%avg_daily_temp(opa) = isite%avg_daily_temp(ipa) osite%avg_monthly_gndwater(opa) = isite%avg_monthly_gndwater(ipa) @@ -6007,6 +5892,7 @@ subroutine copy_sitetype(isite,osite,ipaa,ipaz,opaa,opaz) osite%wbudget_residual(opa) = isite%wbudget_residual(ipa) osite%ebudget_loss2atm(opa) = isite%ebudget_loss2atm(ipa) osite%ebudget_denseffect(opa) = isite%ebudget_denseffect(ipa) + osite%ebudget_prsseffect(opa) = isite%ebudget_prsseffect(ipa) osite%ebudget_loss2runoff(opa) = isite%ebudget_loss2runoff(ipa) osite%ebudget_loss2drainage(opa) = isite%ebudget_loss2drainage(ipa) osite%ebudget_netrad(opa) = isite%ebudget_netrad(ipa) @@ -6058,7 +5944,6 @@ subroutine copy_sitetype(isite,osite,ipaa,ipaz,opaa,opaz) osite%f_decomp(opa) = isite%f_decomp(ipa) osite%rh(opa) = isite%rh(ipa) osite%cwd_rh(opa) = isite%cwd_rh(ipa) - osite%fuse_flag(opa) = isite%fuse_flag(ipa) osite%plant_ag_biomass(opa) = isite%plant_ag_biomass(ipa) osite%mean_wflux(opa) = isite%mean_wflux(ipa) osite%mean_latflux(opa) = isite%mean_latflux(ipa) @@ -6067,6 +5952,7 @@ subroutine copy_sitetype(isite,osite,ipaa,ipaz,opaa,opaz) osite%mean_runoff(opa) = isite%mean_runoff(ipa) osite%mean_qrunoff(opa) = isite%mean_qrunoff(ipa) osite%htry(opa) = isite%htry(ipa) + osite%hprev(opa) = isite%hprev(ipa) osite%avg_rk4step(opa) = isite%avg_rk4step(ipa) osite%avg_available_water(opa) = isite%avg_available_water(ipa) osite%ustar(opa) = isite%ustar(ipa) @@ -6116,7 +6002,6 @@ subroutine copy_sitetype(isite,osite,ipaa,ipaz,opaa,opaz) osite%avg_runoff(opa) = isite%avg_runoff(ipa) osite%avg_drainage(opa) = isite%avg_drainage(ipa) osite%avg_drainage_heat(opa) = isite%avg_drainage_heat(ipa) - osite%aux(opa) = isite%aux(ipa) osite%avg_sensible_lc(opa) = isite%avg_sensible_lc(ipa) osite%avg_sensible_wc(opa) = isite%avg_sensible_wc(ipa) osite%avg_qwshed_vg(opa) = isite%avg_qwshed_vg(ipa) @@ -6161,7 +6046,6 @@ subroutine copy_sitetype(isite,osite,ipaa,ipaz,opaa,opaz) osite%avg_smoist_gg(k,opa) = isite%avg_smoist_gg(k,ipa) osite%avg_transloss(k,opa) = isite%avg_transloss(k,ipa) osite%avg_sensible_gg(k,opa) = isite%avg_sensible_gg(k,ipa) - osite%aux_s(k,opa) = isite%aux_s(k,ipa) end do !----- PFT types. ----------------------------------------------------------------! @@ -6169,35 +6053,10 @@ subroutine copy_sitetype(isite,osite,ipaa,ipaz,opaa,opaz) osite%repro(ipft,opa) = isite%repro(ipft,ipa) osite%A_o_max(ipft,opa) = isite%A_o_max(ipft,ipa) osite%A_c_max(ipft,opa) = isite%A_c_max(ipft,ipa) - - do isto=1,n_stoma_atts - osite%old_stoma_vector_max(isto,ipft,opa) = & - isite%old_stoma_vector_max(isto,ipft,ipa) - end do do ihgt=1,ff_nhgt osite%cumlai_profile(ipft,ihgt,opa) = isite%cumlai_profile(ipft,ihgt,ipa) end do - - !----- This is to copy the old_stoma_data_max structure. ----------------------! - osdo => osite%old_stoma_data_max(ipft,opa) - osdi => isite%old_stoma_data_max(ipft,ipa) - - osdo%recalc = osdi%recalc - osdo%T_L = osdi%T_L - osdo%e_A = osdi%e_A - osdo%PAR = osdi%PAR - osdo%rb_factor = osdi%rb_factor - osdo%prss = osdi%prss - osdo%phenology_factor = osdi%phenology_factor - osdo%gsw_open = osdi%gsw_open - osdo%ilimit = osdi%ilimit - osdo%T_L_residual = osdi%T_L_residual - osdo%e_a_residual = osdi%e_a_residual - osdo%par_residual = osdi%par_residual - osdo%rb_residual = osdi%rb_residual - osdo%leaf_residual = osdi%leaf_residual - osdo%gsw_residual = osdi%gsw_residual end do !----- DBH types. ----------------------------------------------------------------! @@ -6211,7 +6070,6 @@ subroutine copy_sitetype(isite,osite,ipaa,ipaz,opaa,opaz) osite%dmean_co2_residual (opa) = isite%dmean_co2_residual (ipa) osite%dmean_energy_residual(opa) = isite%dmean_energy_residual(ipa) osite%dmean_water_residual (opa) = isite%dmean_water_residual (ipa) - osite%dmean_lambda_light (opa) = isite%dmean_lambda_light (ipa) osite%dmean_A_decomp (opa) = isite%dmean_A_decomp (ipa) osite%dmean_Af_decomp (opa) = isite%dmean_Af_decomp (ipa) osite%dmean_rk4step (opa) = isite%dmean_rk4step (ipa) @@ -6225,7 +6083,6 @@ subroutine copy_sitetype(isite,osite,ipaa,ipaz,opaa,opaz) osite%mmean_co2_residual (opa) = isite%mmean_co2_residual (ipa) osite%mmean_energy_residual(opa) = isite%mmean_energy_residual(ipa) osite%mmean_water_residual (opa) = isite%mmean_water_residual (ipa) - osite%mmean_lambda_light (opa) = isite%mmean_lambda_light (ipa) osite%mmean_A_decomp (opa) = isite%mmean_A_decomp (ipa) osite%mmean_Af_decomp (opa) = isite%mmean_Af_decomp (ipa) osite%mmean_rk4step (opa) = isite%mmean_rk4step (ipa) @@ -6282,7 +6139,6 @@ subroutine copy_sitetype_mask(sitein,siteout,logmask,masksz,newsz) integer,dimension(newsz) :: incmask logical,dimension(masksz) :: logmask integer :: i,k,m,inc,ipft,icyc - type(stoma_data),pointer :: osdi,osdo inc = 0 do i=1,masksz @@ -6310,6 +6166,7 @@ subroutine copy_sitetype_mask(sitein,siteout,logmask,masksz,newsz) siteout%cohort_count(1:inc) = pack(sitein%cohort_count,logmask) siteout%can_theiv(1:inc) = pack(sitein%can_theiv,logmask) siteout%can_temp(1:inc) = pack(sitein%can_temp,logmask) + siteout%can_temp_pv(1:inc) = pack(sitein%can_temp_pv,logmask) siteout%can_shv(1:inc) = pack(sitein%can_shv,logmask) siteout%can_co2(1:inc) = pack(sitein%can_co2,logmask) siteout%can_rhos(1:inc) = pack(sitein%can_rhos,logmask) @@ -6321,9 +6178,7 @@ subroutine copy_sitetype_mask(sitein,siteout,logmask,masksz,newsz) siteout%ggveg(1:inc) = pack(sitein%ggveg,logmask) siteout%ggnet(1:inc) = pack(sitein%ggnet,logmask) siteout%ggsoil(1:inc) = pack(sitein%ggsoil,logmask) - siteout%lambda_light(1:inc) = pack(sitein%lambda_light,logmask) siteout%lai(1:inc) = pack(sitein%lai,logmask) - siteout%wpa(1:inc) = pack(sitein%wpa,logmask) siteout%wai(1:inc) = pack(sitein%wai,logmask) siteout%avg_daily_temp(1:inc) = pack(sitein%avg_daily_temp,logmask) siteout%avg_monthly_gndwater(1:inc) = pack(sitein%avg_monthly_gndwater,logmask) @@ -6338,6 +6193,7 @@ subroutine copy_sitetype_mask(sitein,siteout,logmask,masksz,newsz) siteout%wbudget_residual(1:inc) = pack(sitein%wbudget_residual,logmask) siteout%ebudget_loss2atm(1:inc) = pack(sitein%ebudget_loss2atm,logmask) siteout%ebudget_denseffect(1:inc) = pack(sitein%ebudget_denseffect,logmask) + siteout%ebudget_prsseffect(1:inc) = pack(sitein%ebudget_prsseffect,logmask) siteout%ebudget_loss2runoff(1:inc) = pack(sitein%ebudget_loss2runoff,logmask) siteout%ebudget_loss2drainage(1:inc) = pack(sitein%ebudget_loss2drainage,logmask) siteout%ebudget_netrad(1:inc) = pack(sitein%ebudget_netrad,logmask) @@ -6389,7 +6245,6 @@ subroutine copy_sitetype_mask(sitein,siteout,logmask,masksz,newsz) siteout%f_decomp(1:inc) = pack(sitein%f_decomp,logmask) siteout%rh(1:inc) = pack(sitein%rh,logmask) siteout%cwd_rh(1:inc) = pack(sitein%cwd_rh,logmask) - siteout%fuse_flag(1:inc) = pack(sitein%fuse_flag,logmask) siteout%plant_ag_biomass(1:inc) = pack(sitein%plant_ag_biomass,logmask) siteout%mean_wflux(1:inc) = pack(sitein%mean_wflux,logmask) siteout%mean_latflux(1:inc) = pack(sitein%mean_latflux,logmask) @@ -6398,6 +6253,7 @@ subroutine copy_sitetype_mask(sitein,siteout,logmask,masksz,newsz) siteout%mean_runoff(1:inc) = pack(sitein%mean_runoff,logmask) siteout%mean_qrunoff(1:inc) = pack(sitein%mean_qrunoff,logmask) siteout%htry(1:inc) = pack(sitein%htry,logmask) + siteout%hprev(1:inc) = pack(sitein%hprev,logmask) siteout%avg_rk4step(1:inc) = pack(sitein%avg_rk4step,logmask) siteout%avg_available_water(1:inc) = pack(sitein%avg_available_water,logmask) siteout%ustar(1:inc) = pack(sitein%ustar,logmask) @@ -6447,7 +6303,6 @@ subroutine copy_sitetype_mask(sitein,siteout,logmask,masksz,newsz) siteout%avg_runoff(1:inc) = pack(sitein%avg_runoff,logmask) siteout%avg_drainage(1:inc) = pack(sitein%avg_drainage,logmask) siteout%avg_drainage_heat(1:inc) = pack(sitein%avg_drainage_heat,logmask) - siteout%aux(1:inc) = pack(sitein%aux,logmask) siteout%avg_sensible_lc(1:inc) = pack(sitein%avg_sensible_lc,logmask) siteout%avg_sensible_wc(1:inc) = pack(sitein%avg_sensible_wc,logmask) siteout%avg_qwshed_vg(1:inc) = pack(sitein%avg_qwshed_vg,logmask) @@ -6494,7 +6349,6 @@ subroutine copy_sitetype_mask(sitein,siteout,logmask,masksz,newsz) siteout%avg_smoist_gg(k,1:inc) = pack(sitein%avg_smoist_gg(k,:),logmask) siteout%avg_transloss(k,1:inc) = pack(sitein%avg_transloss(k,:),logmask) siteout%avg_sensible_gg(k,1:inc) = pack(sitein%avg_sensible_gg(k,:),logmask) - siteout%aux_s(k,1:inc) = pack(sitein%aux_s(k,:),logmask) end do ! pft types @@ -6503,10 +6357,6 @@ subroutine copy_sitetype_mask(sitein,siteout,logmask,masksz,newsz) siteout%repro(k,1:inc) = pack(sitein%repro(k,:),logmask) siteout%A_o_max(k,1:inc) = pack(sitein%A_o_max(k,:),logmask) siteout%A_c_max(k,1:inc) = pack(sitein%A_c_max(k,:),logmask) - - do m=1,n_stoma_atts - siteout%old_stoma_vector_max(m,k,1:inc) = pack(sitein%old_stoma_vector_max(m,k,:),logmask) - end do do m=1,ff_nhgt siteout%cumlai_profile(k,m,1:inc) = pack(sitein%cumlai_profile(k,m,:),logmask) @@ -6518,47 +6368,18 @@ subroutine copy_sitetype_mask(sitein,siteout,logmask,masksz,newsz) siteout%co2budget_gpp_dbh(k,1:inc) = pack(sitein%co2budget_gpp_dbh(k,:),logmask) end do - - ! Old_stoma_data_max type - ! Derived type with n_pft x n_patch, so.... the intrinsic "pack" wont work - do m=1,newsz k=incmask(m) call allocate_patchtype(siteout%patch(m),sitein%patch(k)%ncohorts) - call copy_patchtype(sitein%patch(k),siteout%patch(m),1,sitein%patch(k)%ncohorts,1,sitein%patch(k)%ncohorts) + end do - do ipft=1,n_pft - osdo => siteout%old_stoma_data_max(ipft,m) - osdi => sitein%old_stoma_data_max(ipft,k) - - osdo%recalc = osdi%recalc - osdo%T_L = osdi%T_L - osdo%e_A = osdi%e_A - osdo%PAR = osdi%PAR - osdo%rb_factor = osdi%rb_factor - osdo%prss = osdi%prss - osdo%phenology_factor = osdi%phenology_factor - osdo%gsw_open = osdi%gsw_open - osdo%ilimit = osdi%ilimit - osdo%T_L_residual = osdi%T_L_residual - osdo%e_a_residual = osdi%e_a_residual - osdo%par_residual = osdi%par_residual - osdo%rb_residual = osdi%rb_residual - osdo%leaf_residual = osdi%leaf_residual - osdo%gsw_residual = osdi%gsw_residual - - end do - - end do - if (idoutput > 0 .or. imoutput > 0 .or. iqoutput > 0) then siteout%dmean_rh (1:inc) = pack(sitein%dmean_rh ,logmask) siteout%dmean_co2_residual (1:inc) = pack(sitein%dmean_co2_residual ,logmask) siteout%dmean_energy_residual(1:inc) = pack(sitein%dmean_energy_residual,logmask) siteout%dmean_water_residual (1:inc) = pack(sitein%dmean_water_residual ,logmask) - siteout%dmean_lambda_light (1:inc) = pack(sitein%dmean_lambda_light ,logmask) siteout%dmean_A_decomp (1:inc) = pack(sitein%dmean_A_decomp ,logmask) siteout%dmean_Af_decomp (1:inc) = pack(sitein%dmean_Af_decomp ,logmask) siteout%dmean_rk4step (1:inc) = pack(sitein%dmean_rk4step ,logmask) @@ -6572,7 +6393,6 @@ subroutine copy_sitetype_mask(sitein,siteout,logmask,masksz,newsz) siteout%mmean_co2_residual (1:inc) = pack(sitein%mmean_co2_residual ,logmask) siteout%mmean_energy_residual(1:inc) = pack(sitein%mmean_energy_residual,logmask) siteout%mmean_water_residual (1:inc) = pack(sitein%mmean_water_residual ,logmask) - siteout%mmean_lambda_light (1:inc) = pack(sitein%mmean_lambda_light ,logmask) siteout%mmean_A_decomp (1:inc) = pack(sitein%mmean_A_decomp ,logmask) siteout%mmean_Af_decomp (1:inc) = pack(sitein%mmean_Af_decomp ,logmask) siteout%mmean_rk4step (1:inc) = pack(sitein%mmean_rk4step ,logmask) @@ -6624,7 +6444,6 @@ subroutine copy_patchtype_mask(patchin,patchout,mask,masksz,newsz) integer,dimension(masksz):: imask logical,dimension(masksz) :: mask integer :: i,k,m,inc - type(stoma_data),pointer :: osdi,osdo do i=1,masksz imask(i) = i @@ -6651,7 +6470,6 @@ subroutine copy_patchtype_mask(patchin,patchout,mask,masksz,newsz) patchout%broot(1:inc) = pack(patchin%broot,mask) patchout%bsapwood(1:inc) = pack(patchin%bsapwood,mask) patchout%lai(1:inc) = pack(patchin%lai,mask) - patchout%wpa(1:inc) = pack(patchin%wpa,mask) patchout%wai(1:inc) = pack(patchin%wai,mask) patchout%crown_area(1:inc) = pack(patchin%crown_area,mask) patchout%leaf_resolvable(1:inc) = pack(patchin%leaf_resolvable,mask) @@ -6661,11 +6479,13 @@ subroutine copy_patchtype_mask(patchin,patchout,mask,masksz,newsz) patchout%leaf_energy(1:inc) = pack(patchin%leaf_energy,mask) patchout%leaf_hcap(1:inc) = pack(patchin%leaf_hcap,mask) patchout%leaf_temp(1:inc) = pack(patchin%leaf_temp,mask) + patchout%leaf_temp_pv(1:inc) = pack(patchin%leaf_temp_pv,mask) patchout%leaf_fliq(1:inc) = pack(patchin%leaf_fliq,mask) patchout%leaf_water(1:inc) = pack(patchin%leaf_water,mask) patchout%wood_energy(1:inc) = pack(patchin%wood_energy,mask) patchout%wood_hcap(1:inc) = pack(patchin%wood_hcap,mask) patchout%wood_temp(1:inc) = pack(patchin%wood_temp,mask) + patchout%wood_temp_pv(1:inc) = pack(patchin%wood_temp_pv,mask) patchout%wood_fliq(1:inc) = pack(patchin%wood_fliq,mask) patchout%wood_water(1:inc) = pack(patchin%wood_water,mask) patchout%veg_wind(1:inc) = pack(patchin%veg_wind,mask) @@ -6707,9 +6527,6 @@ subroutine copy_patchtype_mask(patchin,patchout,mask,masksz,newsz) patchout%light_level(1:inc) = pack(patchin%light_level,mask) patchout%light_level_beam(1:inc) = pack(patchin%light_level_beam,mask) patchout%light_level_diff(1:inc) = pack(patchin%light_level_diff,mask) - patchout%beamext_level(1:inc) = pack(patchin%beamext_level,mask) - patchout%diffext_level(1:inc) = pack(patchin%diffext_level,mask) - patchout%lambda_light(1:inc) = pack(patchin%lambda_light,mask) patchout%par_l(1:inc) = pack(patchin%par_l,mask) patchout%par_l_beam(1:inc) = pack(patchin%par_l_beam,mask) patchout%par_l_diffuse(1:inc) = pack(patchin%par_l_diffuse,mask) @@ -6758,41 +6575,13 @@ subroutine copy_patchtype_mask(patchin,patchout,mask,masksz,newsz) patchout%cb(i,m) = patchin%cb(i,k) patchout%cb_max(i,m) = patchin%cb_max(i,k) end do - do i = 1,n_stoma_atts - patchout%old_stoma_vector(i,m) = patchin%old_stoma_vector(i,k) - end do do i = 1,n_mort patchout%mort_rate(i,m) = patchin%mort_rate(i,k) end do end do - - - ! Copy the stoma data - do m=1,inc - k=incmask(m) - - osdo => patchout%old_stoma_data(m) - osdi => patchin%old_stoma_data(k) - - osdo%recalc = osdi%recalc - osdo%T_L = osdi%T_L - osdo%e_A = osdi%e_A - osdo%PAR = osdi%PAR - osdo%rb_factor = osdi%rb_factor - osdo%prss = osdi%prss - osdo%phenology_factor = osdi%phenology_factor - osdo%gsw_open = osdi%gsw_open - osdo%ilimit = osdi%ilimit - osdo%T_L_residual = osdi%T_L_residual - osdo%e_a_residual = osdi%e_a_residual - osdo%par_residual = osdi%par_residual - osdo%rb_residual = osdi%rb_residual - osdo%leaf_residual = osdi%leaf_residual - osdo%gsw_residual = osdi%gsw_residual - - end do - + + if (idoutput > 0 .or. imoutput > 0 .or. iqoutput > 0) then patchout%dmean_fs_open (1:inc) = pack(patchin%dmean_fs_open ,mask) patchout%dmean_fsw (1:inc) = pack(patchin%dmean_fsw ,mask) @@ -6800,12 +6589,9 @@ subroutine copy_patchtype_mask(patchin,patchout,mask,masksz,newsz) patchout%dmean_psi_open (1:inc) = pack(patchin%dmean_psi_open ,mask) patchout%dmean_psi_closed (1:inc) = pack(patchin%dmean_psi_closed ,mask) patchout%dmean_water_supply (1:inc) = pack(patchin%dmean_water_supply ,mask) - patchout%dmean_lambda_light (1:inc) = pack(patchin%dmean_lambda_light ,mask) patchout%dmean_light_level (1:inc) = pack(patchin%dmean_light_level ,mask) patchout%dmean_light_level_beam(1:inc) = pack(patchin%dmean_light_level_beam,mask) patchout%dmean_light_level_diff(1:inc) = pack(patchin%dmean_light_level_diff,mask) - patchout%dmean_beamext_level (1:inc) = pack(patchin%dmean_beamext_level ,mask) - patchout%dmean_diffext_level (1:inc) = pack(patchin%dmean_diffext_level ,mask) patchout%dmean_gpp (1:inc) = pack(patchin%dmean_gpp ,mask) patchout%dmean_nppleaf (1:inc) = pack(patchin%dmean_nppleaf ,mask) patchout%dmean_nppfroot (1:inc) = pack(patchin%dmean_nppfroot ,mask) @@ -6831,12 +6617,9 @@ subroutine copy_patchtype_mask(patchin,patchout,mask,masksz,newsz) patchout%mmean_root_maintenance(1:inc) = pack(patchin%mmean_root_maintenance,mask) patchout%mmean_leaf_drop (1:inc) = pack(patchin%mmean_leaf_drop ,mask) patchout%mmean_cb (1:inc) = pack(patchin%mmean_cb ,mask) - patchout%mmean_lambda_light (1:inc) = pack(patchin%mmean_lambda_light ,mask) patchout%mmean_light_level (1:inc) = pack(patchin%mmean_light_level ,mask) patchout%mmean_light_level_beam(1:inc) = pack(patchin%mmean_light_level_beam,mask) patchout%mmean_light_level_diff(1:inc) = pack(patchin%mmean_light_level_diff,mask) - patchout%mmean_beamext_level (1:inc) = pack(patchin%mmean_beamext_level ,mask) - patchout%mmean_diffext_level (1:inc) = pack(patchin%mmean_diffext_level ,mask) patchout%mmean_gpp (1:inc) = pack(patchin%mmean_gpp ,mask) patchout%mmean_nppleaf (1:inc) = pack(patchin%mmean_nppleaf ,mask) patchout%mmean_nppfroot (1:inc) = pack(patchin%mmean_nppfroot ,mask) @@ -6895,7 +6678,6 @@ subroutine copy_patchtype(patchin,patchout,ipin1,ipin2,ipout1,ipout2) implicit none integer :: ipin1,ipin2,ipout1,ipout2 type(patchtype),target :: patchin,patchout - type(stoma_data),pointer :: osdo,osdi integer :: iout,iin if (ipout2-ipout1.ne.ipin2-ipin1) then @@ -6928,7 +6710,6 @@ subroutine copy_patchtype(patchin,patchout,ipin1,ipin2,ipout1,ipout2) patchout%broot(iout) = patchin%broot(iin) patchout%bsapwood(iout) = patchin%bsapwood(iin) patchout%lai(iout) = patchin%lai(iin) - patchout%wpa(iout) = patchin%wpa(iin) patchout%wai(iout) = patchin%wai(iin) patchout%crown_area(iout) = patchin%crown_area(iin) patchout%leaf_resolvable(iout) = patchin%leaf_resolvable(iin) @@ -6940,11 +6721,13 @@ subroutine copy_patchtype(patchin,patchout,ipin1,ipin2,ipout1,ipout2) patchout%leaf_energy(iout) = patchin%leaf_energy(iin) patchout%leaf_hcap(iout) = patchin%leaf_hcap(iin) patchout%leaf_temp(iout) = patchin%leaf_temp(iin) + patchout%leaf_temp_pv(iout) = patchin%leaf_temp_pv(iin) patchout%leaf_fliq(iout) = patchin%leaf_fliq(iin) patchout%leaf_water(iout) = patchin%leaf_water(iin) patchout%wood_energy(iout) = patchin%wood_energy(iin) patchout%wood_hcap(iout) = patchin%wood_hcap(iin) patchout%wood_temp(iout) = patchin%wood_temp(iin) + patchout%wood_temp_pv(iout) = patchin%wood_temp_pv(iin) patchout%wood_fliq(iout) = patchin%wood_fliq(iin) patchout%wood_water(iout) = patchin%wood_water(iin) patchout%veg_wind(iout) = patchin%veg_wind(iin) @@ -6987,9 +6770,6 @@ subroutine copy_patchtype(patchin,patchout,ipin1,ipin2,ipout1,ipout2) patchout%light_level(iout) = patchin%light_level(iin) patchout%light_level_beam(iout) = patchin%light_level_beam(iin) patchout%light_level_diff(iout) = patchin%light_level_diff(iin) - patchout%beamext_level(iout) = patchin%beamext_level(iin) - patchout%diffext_level(iout) = patchin%diffext_level(iin) - patchout%lambda_light(iout) = patchin%lambda_light(iin) patchout%par_l(iout) = patchin%par_l(iin) patchout%par_l_beam(iout) = patchin%par_l_beam(iin) patchout%par_l_diffuse(iout) = patchin%par_l_diffuse(iin) @@ -7032,27 +6812,6 @@ subroutine copy_patchtype(patchin,patchout,ipin1,ipin2,ipout1,ipout2) patchout%vm_bar(iout) = patchin%vm_bar(iin) patchout%sla(iout) = patchin%sla(iin) - patchout%old_stoma_vector(:,iout) = patchin%old_stoma_vector(:,iin) - - osdo => patchout%old_stoma_data(iout) - osdi => patchin%old_stoma_data(iin) - - osdo%recalc = osdi%recalc - osdo%T_L = osdi%T_L - osdo%e_A = osdi%e_A - osdo%PAR = osdi%PAR - osdo%rb_factor = osdi%rb_factor - osdo%prss = osdi%prss - osdo%phenology_factor = osdi%phenology_factor - osdo%gsw_open = osdi%gsw_open - osdo%ilimit = osdi%ilimit - osdo%T_L_residual = osdi%T_L_residual - osdo%e_a_residual = osdi%e_a_residual - osdo%par_residual = osdi%par_residual - osdo%rb_residual = osdi%rb_residual - osdo%leaf_residual = osdi%leaf_residual - osdo%gsw_residual = osdi%gsw_residual - if (imoutput > 0 .or. idoutput > 0 .or. iqoutput > 0) then patchout%dmean_fs_open (iout) = patchin%dmean_fs_open (iin) patchout%dmean_fsw (iout) = patchin%dmean_fsw (iin) @@ -7063,9 +6822,6 @@ subroutine copy_patchtype(patchin,patchout,ipin1,ipin2,ipout1,ipout2) patchout%dmean_light_level (iout) = patchin%dmean_light_level (iin) patchout%dmean_light_level_beam (iout) = patchin%dmean_light_level_beam (iin) patchout%dmean_light_level_diff (iout) = patchin%dmean_light_level_diff (iin) - patchout%dmean_beamext_level (iout) = patchin%dmean_beamext_level (iin) - patchout%dmean_diffext_level (iout) = patchin%dmean_diffext_level (iin) - patchout%dmean_lambda_light (iout) = patchin%dmean_lambda_light (iin) patchout%dmean_gpp (iout) = patchin%dmean_gpp (iin) patchout%dmean_nppleaf (iout) = patchin%dmean_nppleaf (iin) patchout%dmean_nppfroot (iout) = patchin%dmean_nppfroot (iin) @@ -7094,8 +6850,6 @@ subroutine copy_patchtype(patchin,patchout,ipin1,ipin2,ipout1,ipout2) patchout%mmean_light_level (iout) = patchin%mmean_light_level (iin) patchout%mmean_light_level_beam (iout) = patchin%mmean_light_level_beam (iin) patchout%mmean_light_level_diff (iout) = patchin%mmean_light_level_diff (iin) - patchout%mmean_beamext_level (iout) = patchin%mmean_beamext_level (iin) - patchout%mmean_diffext_level (iout) = patchin%mmean_diffext_level (iin) patchout%mmean_gpp (iout) = patchin%mmean_gpp (iin) patchout%mmean_nppleaf (iout) = patchin%mmean_nppleaf (iin) patchout%mmean_nppfroot (iout) = patchin%mmean_nppfroot (iin) @@ -7110,7 +6864,6 @@ subroutine copy_patchtype(patchin,patchout,ipin1,ipin2,ipout1,ipout2) patchout%mmean_storage_resp (iout) = patchin%mmean_storage_resp (iin) patchout%mmean_vleaf_resp (iout) = patchin%mmean_vleaf_resp (iin) patchout%mmean_mort_rate (:,iout) = patchin%mmean_mort_rate (:,iin) - patchout%mmean_lambda_light (iout) = patchin%mmean_lambda_light (iin) patchout%mmean_par_l (iout) = patchin%mmean_par_l (iin) patchout%mmean_par_l_beam (iout) = patchin%mmean_par_l_beam (iin) patchout%mmean_par_l_diff (iout) = patchin%mmean_par_l_diff (iin) @@ -7269,7 +7022,7 @@ subroutine filltab_alltypes ! ================================================= - use ed_var_tables,only:num_var,vt_info,var_table,nullify_vt_vector_pointers + use ed_var_tables,only:num_var,vt_info,var_table,reset_vt_vector_pointers use ed_node_coms,only:mynum,mchnum,machs,nmachs,nnodetot,sendnum,recvnum,master_num use ed_max_dims, only: maxgrds, maxmach implicit none @@ -7300,12 +7053,7 @@ subroutine filltab_alltypes if (num_var(igr)>0) then do nv=1,num_var(igr) - if (associated(vt_info(nv,igr)%vt_vector)) then - do iptr=1,vt_info(nv,igr)%nptrs - call nullify_vt_vector_pointers(vt_info(nv,igr)%vt_vector(iptr)) - end do - deallocate(vt_info(nv,igr)%vt_vector) - end if + call reset_vt_vector_pointers(vt_info(nv,igr)) end do end if @@ -8128,13 +7876,6 @@ subroutine filltab_edtype_p11(cgrid,igr,init,var_len,var_len_global,max_ptrs,nva var_len,var_len_global,max_ptrs,'AVG_DRAINAGE_HEAT :11:hist:anal') call metadata_edio(nvar,igr,'polygon average internal energy loss through lower soil layer','[W/m2]','ipoly') end if - - if (associated(cgrid%aux)) then - nvar=nvar+1 - call vtable_edio_r(npts,cgrid%aux,nvar,igr,init,cgrid%pyglob_id, & - var_len,var_len_global,max_ptrs,'AUX :11:hist:anal') - call metadata_edio(nvar,igr,'Auxillary variable - user discretion,see rk4_derivs.f90','[user-defined]','ipoly') - end if if (associated(cgrid%avg_rshort_gnd)) then @@ -8317,13 +8058,6 @@ subroutine filltab_edtype_p11(cgrid,igr,init,var_len,var_len_global,max_ptrs,nva call metadata_edio(nvar,igr,'Polygon LAI','[m2/m2]','ipoly') end if - if (associated(cgrid%wpa)) then - nvar=nvar+1 - call vtable_edio_r(npts,cgrid%wpa,nvar,igr,init,cgrid%pyglob_id, & - var_len,var_len_global,max_ptrs,'WPA :11:hist:anal:dail') - call metadata_edio(nvar,igr,'Polygon wood projected area','[m2/m2]','ipoly') - end if - if (associated(cgrid%avg_lma)) then nvar=nvar+1 call vtable_edio_r(npts,cgrid%avg_lma,nvar,igr,init,cgrid%pyglob_id, & @@ -10903,13 +10637,6 @@ subroutine filltab_edtype_p12(cgrid,igr,init,var_len,var_len_global,max_ptrs,nva call metadata_edio(nvar,igr,'Polygon averaged soil moisture sink to transpiration','[kg/m2/s]','ipoly-nzg') end if - if (associated(cgrid%aux_s)) then - nvar=nvar+1 - call vtable_edio_r(npts,cgrid%aux_s,nvar,igr,init,cgrid%pyglob_id, & - var_len,var_len_global,max_ptrs,'AUX_S :12:hist:anal') - call metadata_edio(nvar,igr,'Soil layer discretized, auxillary variable, see rk4_derivs.f90','[user-defined]','ipoly-nzg') - end if - if (associated(cgrid%avg_sensible_gg)) then nvar=nvar+1 @@ -11136,13 +10863,6 @@ subroutine filltab_edtype_p14(cgrid,igr,init,var_len,var_len_global,max_ptrs,nva call metadata_edio(nvar,igr,'Leaf Area Index','[m2/m2]','NA') end if - if(associated(cgrid%wpa_pft)) then - nvar=nvar+1 - call vtable_edio_r(npts,cgrid%wpa_pft,nvar,igr,init,cgrid%pyglob_id, & - var_len,var_len_global,max_ptrs,'WPA_PFT :14:hist:anal:dail') - call metadata_edio(nvar,igr,'Wood Projected Area','[m2/m2]','NA') - end if - if(associated(cgrid%wai_pft)) then nvar=nvar+1 call vtable_edio_r(npts,cgrid%wai_pft,nvar,igr,init,cgrid%pyglob_id, & @@ -11157,13 +10877,6 @@ subroutine filltab_edtype_p14(cgrid,igr,init,var_len,var_len_global,max_ptrs,nva call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if - if(associated(cgrid%mmean_wpa_pft)) then - nvar=nvar+1 - call vtable_edio_r(npts,cgrid%mmean_wpa_pft,nvar,igr,init,cgrid%pyglob_id, & - var_len,var_len_global,max_ptrs,'MMEAN_WPA_PFT :14:hist:mont:dcyc') - call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') - end if - if(associated(cgrid%mmean_wai_pft)) then nvar=nvar+1 call vtable_edio_r(npts,cgrid%mmean_wai_pft,nvar,igr,init,cgrid%pyglob_id, & @@ -11884,13 +11597,6 @@ subroutine filltab_polygontype(igr,ipy,init) call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if - if (associated(cpoly%wpa_pft)) then - nvar=nvar+1 - call vtable_edio_r(npts,cpoly%wpa_pft,nvar,igr,init,cpoly%siglob_id, & - var_len,var_len_global,max_ptrs,'WPA_PFT_SI :24:hist:dail') - call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') - end if - if (associated(cpoly%wai_pft)) then nvar=nvar+1 call vtable_edio_r(npts,cpoly%wai_pft,nvar,igr,init,cpoly%siglob_id, & @@ -12165,13 +11871,6 @@ subroutine filltab_sitetype(igr,ipy,isi,init) call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if - if (associated(csite%fuse_flag)) then - nvar=nvar+1 - call vtable_edio_i(npts,csite%fuse_flag,nvar,igr,init,csite%paglob_id, & - var_len,var_len_global,max_ptrs,'FUSE_FLAG :30:hist') - call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') - end if - if (associated(csite%age)) then nvar=nvar+1 call vtable_edio_r(npts,csite%age,nvar,igr,init,csite%paglob_id, & @@ -12258,6 +11957,13 @@ subroutine filltab_sitetype(igr,ipy,isi,init) call metadata_edio(nvar,igr,'Canopy air temperature','[K]','NA') end if + if (associated(csite%can_temp_pv)) then + nvar=nvar+1 + call vtable_edio_r(npts,csite%can_temp_pv,nvar,igr,init,csite%paglob_id, & + var_len,var_len_global,max_ptrs,'CAN_TEMP_PV :31:hist') + call metadata_edio(nvar,igr,'Canopy air temperature at previous step','[K]','NA') + end if + if (associated(csite%can_shv)) then nvar=nvar+1 call vtable_edio_r(npts,csite%can_shv,nvar,igr,init,csite%paglob_id, & @@ -12335,27 +12041,6 @@ subroutine filltab_sitetype(igr,ipy,isi,init) call metadata_edio(nvar,igr,'Soil conductance for evaporation','[m/s]','NA') end if - if (associated(csite%lambda_light)) then - nvar=nvar+1 - call vtable_edio_r(npts,csite%lambda_light,nvar,igr,init,csite%paglob_id, & - var_len,var_len_global,max_ptrs,'LAMBDA_LIGHT :31:hist') - call metadata_edio(nvar,igr,'Light extinction','[m2/,2]','NA') - end if - - if (associated(csite%dmean_lambda_light)) then - nvar=nvar+1 - call vtable_edio_r(npts,csite%dmean_lambda_light,nvar,igr,init,csite%paglob_id, & - var_len,var_len_global,max_ptrs,'DMEAN_LAMBDA_LIGHT :31:hist:dail') - call metadata_edio(nvar,igr,'Light extinction','[m2/,2]','NA') - end if - - if (associated(csite%mmean_lambda_light)) then - nvar=nvar+1 - call vtable_edio_r(npts,csite%mmean_lambda_light,nvar,igr,init,csite%paglob_id, & - var_len,var_len_global,max_ptrs,'MMEAN_LAMBDA_LIGHT :31:hist:mont:dcyc') - call metadata_edio(nvar,igr,'Light extinction','[m2/,2]','NA') - end if - if (associated(csite%lai)) then nvar=nvar+1 call vtable_edio_r(npts,csite%lai,nvar,igr,init,csite%paglob_id, & @@ -12363,13 +12048,6 @@ subroutine filltab_sitetype(igr,ipy,isi,init) call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if - if (associated(csite%wpa)) then - nvar=nvar+1 - call vtable_edio_r(npts,csite%wpa,nvar,igr,init,csite%paglob_id, & - var_len,var_len_global,max_ptrs,'WPA_PA :31:hist:dail') - call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') - end if - if (associated(csite%wai)) then nvar=nvar+1 call vtable_edio_r(npts,csite%wai,nvar,igr,init,csite%paglob_id, & @@ -12546,6 +12224,13 @@ subroutine filltab_sitetype(igr,ipy,isi,init) call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if + if (associated(csite%ebudget_prsseffect)) then + nvar=nvar+1 + call vtable_edio_r(npts,csite%ebudget_prsseffect,nvar,igr,init,csite%paglob_id, & + var_len,var_len_global,max_ptrs,'EBUDGET_PRSSEFFECT :31:hist') + call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') + end if + if (associated(csite%ebudget_loss2runoff)) then nvar=nvar+1 call vtable_edio_r(npts,csite%ebudget_loss2runoff,nvar,igr,init,csite%paglob_id, & @@ -12997,6 +12682,13 @@ subroutine filltab_sitetype(igr,ipy,isi,init) call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if + if (associated(csite%hprev)) then + nvar=nvar+1 + call vtable_edio_r(npts,csite%hprev,nvar,igr,init,csite%paglob_id, & + var_len,var_len_global,max_ptrs,'HPREV :31:hist') + call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') + end if + if (associated(csite%avg_rk4step)) then nvar=nvar+1 call vtable_edio_r(npts,csite%avg_rk4step,nvar,igr,init,csite%paglob_id, & @@ -13508,28 +13200,6 @@ subroutine filltab_sitetype(igr,ipy,isi,init) - - - - !------------------------------------------------------------------------------------! - !------------------------------------------------------------------------------------! - ! This part should have only 3-D vectors with dimensions n_stoma_atts and ! - ! n_dbh. Notice that they all use the same npts. Here you should only add vari- ! - ! ables of type 316. ! - !------------------------------------------------------------------------------------! - npts = csite%npatches * n_stoma_atts * n_pft - - if (associated(csite%old_stoma_vector_max)) then - nvar=nvar+1 - call vtable_edio_r(npts,csite%old_stoma_vector_max,nvar,igr,init,csite%paglob_id, & - var_len,var_len_global,max_ptrs,'OLD_STOMA_VECTOR_MAX :316:hist') - call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') - end if - !------------------------------------------------------------------------------------! - !------------------------------------------------------------------------------------! - - - !----- Save the number of patch-level (sitetype) variables that go to the output. ---! if (init == 0) niosite=nvar-niopoly-niogrid-nioglobal !------------------------------------------------------------------------------------! @@ -13645,7 +13315,7 @@ subroutine filltab_patchtype(igr,ipy,isi,ipa,init) if (associated(cpatch%pft)) then nvar=nvar+1 call vtable_edio_i(npts,cpatch%pft,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'PFT :40:hist:anal:dail:mont:dcyc:year') + var_len,var_len_global,max_ptrs,'PFT :40:hist:dail:mont:dcyc:year') call metadata_edio(nvar,igr,'Plant Functional Type','[-]','NA') end if @@ -13660,7 +13330,7 @@ subroutine filltab_patchtype(igr,ipy,isi,ipa,init) if (associated(cpatch%krdepth)) then nvar=nvar+1 call vtable_edio_i(npts,cpatch%krdepth,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'KRDEPTH :40:hist:anal:dail:mont:dcyc:year') + var_len,var_len_global,max_ptrs,'KRDEPTH :40:hist:dail:mont:dcyc:year') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if @@ -13682,28 +13352,28 @@ subroutine filltab_patchtype(igr,ipy,isi,ipa,init) if (associated(cpatch%nplant)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%nplant,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'NPLANT :41:hist:anal:dail:mont:dcyc:year') + var_len,var_len_global,max_ptrs,'NPLANT :41:hist:dail:mont:dcyc:year') call metadata_edio(nvar,igr,'Plant density','[plant/m2]','NA') end if if (associated(cpatch%hite)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%hite,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'HITE :41:hist:anal:dail:mont:dcyc:year') + var_len,var_len_global,max_ptrs,'HITE :41:hist:dail:mont:dcyc:year') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%agb)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%agb,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'AGB_CO :41:hist:anal:dail:mont:dcyc:year') + var_len,var_len_global,max_ptrs,'AGB_CO :41:hist:dail:mont:dcyc:year') call metadata_edio(nvar,igr,'Above-ground biomass','[kgC/plant]','icohort') end if if (associated(cpatch%basarea)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%basarea,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'BA_CO :41:hist:anal:dail:mont:dcyc:year') + var_len,var_len_global,max_ptrs,'BA_CO :41:hist:dail:mont:dcyc:year') call metadata_edio(nvar,igr,'Basal-area','[cm2]','icohort') end if @@ -13731,77 +13401,70 @@ subroutine filltab_patchtype(igr,ipy,isi,ipa,init) if (associated(cpatch%dbh)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%dbh,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'DBH :41:hist:anal:year:dail:mont:dcyc') + var_len,var_len_global,max_ptrs,'DBH :41:hist:year:dail:mont:dcyc') call metadata_edio(nvar,igr,'Diameter at breast height','[cm]','icohort') end if if (associated(cpatch%bdead)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%bdead,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'BDEAD :41:hist:mont:anal:dail:year:dcyc') + var_len,var_len_global,max_ptrs,'BDEAD :41:hist:mont:dail:year:dcyc') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%bleaf)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%bleaf,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'BLEAF :41:hist:year:anal:dail:mont:dcyc') + var_len,var_len_global,max_ptrs,'BLEAF :41:hist:year:dail:mont:dcyc') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%balive)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%balive,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'BALIVE :41:hist:year:dail:anal:mont:dcyc') + var_len,var_len_global,max_ptrs,'BALIVE :41:hist:year:dail:mont:dcyc') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%broot)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%broot,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'BROOT :41:hist:year:dail:anal:mont:dcyc') + var_len,var_len_global,max_ptrs,'BROOT :41:hist:year:dail:mont:dcyc') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%bsapwood)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%bsapwood,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'BSAPWOOD :41:hist:year:dail:anal:mont:dcyc') + var_len,var_len_global,max_ptrs,'BSAPWOOD :41:hist:year:dail:mont:dcyc') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%lai)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%lai,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'LAI_CO :41:hist:dail:anal:mont:year:dcyc') - call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') - end if - - if (associated(cpatch%wpa)) then - nvar=nvar+1 - call vtable_edio_r(npts,cpatch%wpa,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'WPA_CO :41:hist:dail:anal:mont:year:dcyc') + var_len,var_len_global,max_ptrs,'LAI_CO :41:hist:dail:mont:year:dcyc') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%wai)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%wai,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'WAI_CO :41:hist:dail:anal:mont:year:dcyc') + var_len,var_len_global,max_ptrs,'WAI_CO :41:hist:dail:mont:year:dcyc') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%crown_area)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%crown_area,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'CROWN_AREA_CO :41:hist:dail:anal:mont:year:dcyc') + var_len,var_len_global,max_ptrs,'CROWN_AREA_CO :41:hist:dail:mont:year:dcyc') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%bstorage)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%bstorage,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'BSTORAGE :41:hist:year:anal:dail:mont:dcyc') + var_len,var_len_global,max_ptrs,'BSTORAGE :41:hist:year:dail:mont:dcyc') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if @@ -13822,7 +13485,7 @@ subroutine filltab_patchtype(igr,ipy,isi,ipa,init) if (associated(cpatch%leaf_energy)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%leaf_energy,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'LEAF_ENERGY :41:hist:anal') + var_len,var_len_global,max_ptrs,'LEAF_ENERGY :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if @@ -13836,28 +13499,36 @@ subroutine filltab_patchtype(igr,ipy,isi,ipa,init) if (associated(cpatch%leaf_temp)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%leaf_temp,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'LEAF_TEMP :41:hist:anal') + var_len,var_len_global,max_ptrs,'LEAF_TEMP :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if + if (associated(cpatch%leaf_temp_pv)) then + nvar=nvar+1 + call vtable_edio_r(npts,cpatch%leaf_temp_pv,nvar,igr,init,cpatch%coglob_id, & + var_len,var_len_global,max_ptrs,'LEAF_TEMP_PV :41:hist') + call metadata_edio(nvar,igr,'Leaf Temperature at previous step','[]','NA') + end if + + if (associated(cpatch%leaf_fliq)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%leaf_fliq,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'LEAF_FLIQ :41:hist:anal') + var_len,var_len_global,max_ptrs,'LEAF_FLIQ :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%leaf_water)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%leaf_water,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'LEAF_WATER :41:hist:anal') + var_len,var_len_global,max_ptrs,'LEAF_WATER :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%wood_energy)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%wood_energy,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'WOOD_ENERGY :41:hist:anal') + var_len,var_len_global,max_ptrs,'WOOD_ENERGY :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if @@ -13871,98 +13542,106 @@ subroutine filltab_patchtype(igr,ipy,isi,ipa,init) if (associated(cpatch%wood_temp)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%wood_temp,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'WOOD_TEMP :41:hist:anal') + var_len,var_len_global,max_ptrs,'WOOD_TEMP :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if + + if (associated(cpatch%wood_temp_pv)) then + nvar=nvar+1 + call vtable_edio_r(npts,cpatch%wood_temp_pv,nvar,igr,init,cpatch%coglob_id, & + var_len,var_len_global,max_ptrs,'WOOD_TEMP_PV :41:hist') + call metadata_edio(nvar,igr,'Wood temperature at previous step','[NA]','NA') + end if + if (associated(cpatch%wood_fliq)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%wood_fliq,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'WOOD_FLIQ :41:hist:anal') + var_len,var_len_global,max_ptrs,'WOOD_FLIQ :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%wood_water)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%wood_water,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'WOOD_WATER :41:hist:anal') + var_len,var_len_global,max_ptrs,'WOOD_WATER :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%veg_wind)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%veg_wind,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'VEG_WIND :41:hist:anal') + var_len,var_len_global,max_ptrs,'VEG_WIND :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%lsfc_shv_closed)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%lsfc_shv_closed,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'LSFC_SHV_CLOSED :41:hist:anal') + var_len,var_len_global,max_ptrs,'LSFC_SHV_CLOSED :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%lsfc_shv_open)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%lsfc_shv_open,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'LSFC_SHV_OPEN :41:hist:anal') + var_len,var_len_global,max_ptrs,'LSFC_SHV_OPEN :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%lsfc_co2_closed)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%lsfc_co2_closed,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'LSFC_CO2_CLOSED :41:hist:anal') + var_len,var_len_global,max_ptrs,'LSFC_CO2_CLOSED :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%lsfc_co2_open)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%lsfc_co2_open,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'LSFC_CO2_OPEN :41:hist:anal') + var_len,var_len_global,max_ptrs,'LSFC_CO2_OPEN :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%lint_shv)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%lint_shv,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'LINT_SHV :41:hist:anal') + var_len,var_len_global,max_ptrs,'LINT_SHV :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%lint_co2_closed)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%lint_co2_closed,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'LINT_CO2_CLOSED :41:hist:anal') + var_len,var_len_global,max_ptrs,'LINT_CO2_CLOSED :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%lint_co2_open)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%lint_co2_open,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'LINT_CO2_OPEN :41:hist:anal') + var_len,var_len_global,max_ptrs,'LINT_CO2_OPEN :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%mean_gpp)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%mean_gpp,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'MEAN_GPP :41:hist:anal') + var_len,var_len_global,max_ptrs,'MEAN_GPP :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%mean_leaf_resp)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%mean_leaf_resp,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'MEAN_LEAF_RESP :41:hist:anal') + var_len,var_len_global,max_ptrs,'MEAN_LEAF_RESP :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%mean_root_resp)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%mean_root_resp,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'MEAN_ROOT_RESP :41:hist:anal') + var_len,var_len_global,max_ptrs,'MEAN_ROOT_RESP :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if @@ -14053,21 +13732,21 @@ subroutine filltab_patchtype(igr,ipy,isi,ipa,init) if (associated(cpatch%growth_respiration)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%growth_respiration,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'GROWTH_RESPIRATION :41:hist:anal') + var_len,var_len_global,max_ptrs,'GROWTH_RESPIRATION :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%storage_respiration)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%storage_respiration,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'STORAGE_RESPIRATION :41:hist:anal') + var_len,var_len_global,max_ptrs,'STORAGE_RESPIRATION :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%vleaf_respiration)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%vleaf_respiration,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'VLEAF_RESPIRATION :41:hist:anal') + var_len,var_len_global,max_ptrs,'VLEAF_RESPIRATION :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if @@ -14238,7 +13917,7 @@ subroutine filltab_patchtype(igr,ipy,isi,ipa,init) if (associated(cpatch%fsn)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%fsn,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'FSN :41:hist:anal') + var_len,var_len_global,max_ptrs,'FSN :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if @@ -14252,45 +13931,31 @@ subroutine filltab_patchtype(igr,ipy,isi,ipa,init) if (associated(cpatch%Psi_open)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%Psi_open,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'PSI_OPEN :41:hist:anal') + var_len,var_len_global,max_ptrs,'PSI_OPEN :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%light_level)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%light_level,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'LIGHT_LEVEL :41:hist:anal') + var_len,var_len_global,max_ptrs,'LIGHT_LEVEL :41:hist') call metadata_edio(nvar,igr,'Relative light level','[NA]','icohort') end if if (associated(cpatch%light_level_beam)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%light_level_beam,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'LIGHT_LEVEL_BEAM :41:hist:anal') + var_len,var_len_global,max_ptrs,'LIGHT_LEVEL_BEAM :41:hist') call metadata_edio(nvar,igr,'Relative light level, beam fraction','[NA]','icohort') end if if (associated(cpatch%light_level_diff)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%light_level_diff,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'LIGHT_LEVEL_DIFF :41:hist:anal') + var_len,var_len_global,max_ptrs,'LIGHT_LEVEL_DIFF :41:hist') call metadata_edio(nvar,igr,'Relative light level, diffuse fraction','[NA]','icohort') end if - if (associated(cpatch%beamext_level)) then - nvar=nvar+1 - call vtable_edio_r(npts,cpatch%beamext_level,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'BEAMEXT_LEVEL :41:hist:anal') - call metadata_edio(nvar,igr,'Beam extinction level','[NA]','icohort') - end if - - if (associated(cpatch%diffext_level)) then - nvar=nvar+1 - call vtable_edio_r(npts,cpatch%diffext_level,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'DIFFEXT_LEVEL :41:hist:anal') - call metadata_edio(nvar,igr,'diff extinction level','[NA]','icohort') - end if - if (associated(cpatch%dmean_light_level)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%dmean_light_level,nvar,igr,init,cpatch%coglob_id, & @@ -14312,20 +13977,6 @@ subroutine filltab_patchtype(igr,ipy,isi,ipa,init) call metadata_edio(nvar,igr,'Diurnal mean of Relative light level (diffuse)','[NA]','icohort') end if - if (associated(cpatch%dmean_beamext_level)) then - nvar=nvar+1 - call vtable_edio_r(npts,cpatch%dmean_beamext_level,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'DMEAN_BEAMEXT_LEVEL :41:hist:dail') - call metadata_edio(nvar,igr,'Diurnal mean of beam extinction level ','[NA]','icohort') - end if - - if (associated(cpatch%dmean_diffext_level)) then - nvar=nvar+1 - call vtable_edio_r(npts,cpatch%dmean_diffext_level,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'DMEAN_DIFFEXT_LEVEL :41:hist:dail') - call metadata_edio(nvar,igr,'Diurnal mean of diff extinction level ','[NA]','icohort') - end if - if (associated(cpatch%mmean_light_level)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%mmean_light_level,nvar,igr,init,cpatch%coglob_id, & @@ -14347,59 +13998,24 @@ subroutine filltab_patchtype(igr,ipy,isi,ipa,init) call metadata_edio(nvar,igr,'Monthly mean of Relative light level (diff)','[NA]','icohort') end if - if (associated(cpatch%mmean_beamext_level)) then - nvar=nvar+1 - call vtable_edio_r(npts,cpatch%mmean_beamext_level,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'MMEAN_BEAMEXT_LEVEL :41:hist:mont:dcyc') - call metadata_edio(nvar,igr,'Diurnal mean of beam extinction level ','[NA]','icohort') - end if - - if (associated(cpatch%mmean_diffext_level)) then - nvar=nvar+1 - call vtable_edio_r(npts,cpatch%mmean_diffext_level,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'MMEAN_DIFFEXT_LEVEL :41:hist:mont:dcyc') - call metadata_edio(nvar,igr,'Diurnal mean of diff extinction level ','[NA]','icohort') - end if - - if (associated(cpatch%lambda_light)) then - nvar=nvar+1 - call vtable_edio_r(npts,cpatch%lambda_light,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'LAMBDA_LIGHT_CO :41:hist:anal') - call metadata_edio(nvar,igr,'Light extinction','[m2/m2]','icohort') - end if - - if (associated(cpatch%dmean_lambda_light)) then - nvar=nvar+1 - call vtable_edio_r(npts,cpatch%dmean_lambda_light,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'DMEAN_LAMBDA_LIGHT_CO :41:hist:dail') - call metadata_edio(nvar,igr,'Diurnal mean of light extinction ','[m2/m2]','icohort') - end if - - if (associated(cpatch%mmean_lambda_light)) then - nvar=nvar+1 - call vtable_edio_r(npts,cpatch%mmean_lambda_light,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'MMEAN_LAMBDA_LIGHT_CO :41:hist:mont:dcyc') - call metadata_edio(nvar,igr,'Monthly mean of light extinction ','[m2/m2]','icohort') - end if - if (associated(cpatch%par_l)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%par_l,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'PAR_L :41:hist:anal') + var_len,var_len_global,max_ptrs,'PAR_L :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%par_l_beam)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%par_l_beam,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'PAR_L_BEAM :41:hist:anal') + var_len,var_len_global,max_ptrs,'PAR_L_BEAM :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%par_l_diffuse)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%par_l_diffuse,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'PAR_L_DIFFUSE :41:hist:anal') + var_len,var_len_global,max_ptrs,'PAR_L_DIFFUSE :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if @@ -14448,175 +14064,175 @@ subroutine filltab_patchtype(igr,ipy,isi,ipa,init) if (associated(cpatch%rshort_l)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%rshort_l,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'RSHORT_L :41:hist:anal') + var_len,var_len_global,max_ptrs,'RSHORT_L :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%rshort_l_beam)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%rshort_l_beam,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'RSHORT_L_BEAM :41:hist:anal') + var_len,var_len_global,max_ptrs,'RSHORT_L_BEAM :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%rshort_l_diffuse)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%rshort_l_diffuse,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'RSHORT_L_DIFFUSE :41:hist:anal') + var_len,var_len_global,max_ptrs,'RSHORT_L_DIFFUSE :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%rlong_l)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%rlong_l,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'RLONG_L :41:hist:anal') + var_len,var_len_global,max_ptrs,'RLONG_L :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%rlong_l_surf)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%rlong_l_surf,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'RLONG_L_SURF :41:hist:anal') + var_len,var_len_global,max_ptrs,'RLONG_L_SURF :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%rlong_l_incid)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%rlong_l_incid,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'RLONG_L_INCID :41:hist:anal') + var_len,var_len_global,max_ptrs,'RLONG_L_INCID :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%rshort_w)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%rshort_w,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'RSHORT_W :41:hist:anal') + var_len,var_len_global,max_ptrs,'RSHORT_W :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%rshort_w_beam)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%rshort_w_beam,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'RSHORT_W_BEAM :41:hist:anal') + var_len,var_len_global,max_ptrs,'RSHORT_W_BEAM :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%rshort_w_diffuse)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%rshort_w_diffuse,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'RSHORT_W_DIFFUSE :41:hist:anal') + var_len,var_len_global,max_ptrs,'RSHORT_W_DIFFUSE :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%rlong_w)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%rlong_w,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'RLONG_W :41:hist:anal') + var_len,var_len_global,max_ptrs,'RLONG_W :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%rlong_w_surf)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%rlong_w_surf,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'RLONG_W_SURF :41:hist:anal') + var_len,var_len_global,max_ptrs,'RLONG_W_SURF :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%rlong_w_incid)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%rlong_w_incid,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'RLONG_W_INCID :41:hist:anal') + var_len,var_len_global,max_ptrs,'RLONG_W_INCID :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%leaf_gbh)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%leaf_gbh,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'LEAF_GBH :41:hist:anal') + var_len,var_len_global,max_ptrs,'LEAF_GBH :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%leaf_gbw)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%leaf_gbw,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'LEAF_GBW :41:hist:anal') + var_len,var_len_global,max_ptrs,'LEAF_GBW :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%wood_gbh)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%wood_gbh,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'WOOD_GBH :41:hist:anal') + var_len,var_len_global,max_ptrs,'WOOD_GBH :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%wood_gbw)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%wood_gbw,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'WOOD_GBW :41:hist:anal') + var_len,var_len_global,max_ptrs,'WOOD_GBW :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%llspan)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%llspan,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'LLSPAN :41:hist:anal') + var_len,var_len_global,max_ptrs,'LLSPAN :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%A_open)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%A_open,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'A_OPEN :41:hist:anal') + var_len,var_len_global,max_ptrs,'A_OPEN :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%A_closed)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%A_closed,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'A_CLOSED :41:hist:anal') + var_len,var_len_global,max_ptrs,'A_CLOSED :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%Psi_closed)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%Psi_closed,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'PSI_CLOSED :41:hist:anal') + var_len,var_len_global,max_ptrs,'PSI_CLOSED :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%gsw_open)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%gsw_open,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'GSW_OPEN :41:hist:anal') + var_len,var_len_global,max_ptrs,'GSW_OPEN :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%gsw_closed)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%gsw_closed,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'GSW_CLOSED :41:hist:anal') + var_len,var_len_global,max_ptrs,'GSW_CLOSED :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%fsw)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%fsw,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'FSW :41:hist:anal') + var_len,var_len_global,max_ptrs,'FSW :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%fs_open)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%fs_open,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'FS_OPEN :41:hist:anal') + var_len,var_len_global,max_ptrs,'FS_OPEN :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if if (associated(cpatch%water_supply)) then nvar=nvar+1 call vtable_edio_r(npts,cpatch%water_supply,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'WATER_SUPPLY :41:hist:anal') + var_len,var_len_global,max_ptrs,'WATER_SUPPLY :41:hist') call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') end if @@ -14975,27 +14591,6 @@ subroutine filltab_patchtype(igr,ipy,isi,ipa,init) !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! - - - - - !------------------------------------------------------------------------------------! - !------------------------------------------------------------------------------------! - ! This part should have only 2-D vectors, with dimension n_stoma_atts and ! - ! ncohorts. Notice that they all use the same npts. Here you should only add vari- ! - ! ables of type 416. ! - !------------------------------------------------------------------------------------! - npts = cpatch%ncohorts * 16 - - if (associated(cpatch%old_stoma_vector)) then - nvar=nvar+1 - call vtable_edio_r(npts,cpatch%old_stoma_vector,nvar,igr,init,cpatch%coglob_id, & - var_len,var_len_global,max_ptrs,'OLD_STOMA_VECTOR :416:hist') - call metadata_edio(nvar,igr,'No metadata available','[NA]','NA') - end if - !------------------------------------------------------------------------------------! - !------------------------------------------------------------------------------------! - return end subroutine filltab_patchtype !==========================================================================================! diff --git a/ED/src/memory/ed_var_tables.f90 b/ED/src/memory/ed_var_tables.f90 index 1aad1ce9b..48b7e01e4 100644 --- a/ED/src/memory/ed_var_tables.f90 +++ b/ED/src/memory/ed_var_tables.f90 @@ -75,14 +75,30 @@ module ed_var_tables !---------------------------------------------------------------------------------------! ! Define data type for main variable table ! !---------------------------------------------------------------------------------------! - integer, parameter :: maxvars = 1500 + integer, parameter :: maxvars = 1100 + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + type var_table_vector + real , dimension(:), pointer :: var_rp + integer , dimension(:), pointer :: var_ip + character (len=str_len), dimension(:), pointer :: var_cp + real(kind=8) , dimension(:), pointer :: var_dp + real , pointer :: sca_rp + integer , pointer :: sca_ip + character (len=str_len) , pointer :: sca_cp + real(kind=8) , pointer :: sca_dp + integer :: globid + integer :: varlen + end type var_table_vector !---------------------------------------------------------------------------------------! !---------------------------------------------------------------------------------------! type var_table - logical :: first integer :: idim_type integer :: nptrs integer :: ihist @@ -105,30 +121,14 @@ module ed_var_tables character (len=64) :: lname ! Long name for description in file character (len=16) :: units ! Unit description of the data character (len=64) :: dimlab + logical :: vector_allocated !----- Multiple pointer defs (maxptrs) ----------------------------------------------! - type(var_table_vector),pointer,dimension(:) :: vt_vector + type(var_table_vector), allocatable, dimension(:) :: vt_vector end type var_table !---------------------------------------------------------------------------------------! - !---------------------------------------------------------------------------------------! - type var_table_vector - real , dimension(:), pointer :: var_rp - integer , dimension(:), pointer :: var_ip - character (len=str_len), dimension(:), pointer :: var_cp - real(kind=8) , dimension(:), pointer :: var_dp - real , pointer :: sca_rp - integer , pointer :: sca_ip - character (len=str_len) , pointer :: sca_cp - real(kind=8) , pointer :: sca_dp - integer :: globid - integer :: varlen - end type var_table_vector - !---------------------------------------------------------------------------------------! - - - !----- Main variable table allocated to (maxvars,maxgrds) ------------------------------! type(var_table), dimension(:,:), allocatable :: vt_info !---------------------------------------------------------------------------------------! @@ -197,6 +197,9 @@ recursive subroutine vtable_edio_r(npts,var,nv,igr,init,glob_id,var_len,var_len_ ! follow. ! !------------------------------------------------------------------------------------! if (init == 0) then + !----- Make sure we have a clean start. ------------------------------------------! + call reset_vt_vector_pointers(vt_info(nv,igr)) + !---------------------------------------------------------------------------------! !----- Count the number of variables. --------------------------------------------! num_var(igr) = num_var(igr) + 1 @@ -207,7 +210,7 @@ recursive subroutine vtable_edio_r(npts,var,nv,igr,init,glob_id,var_len,var_len_ vt_info(nv,igr)%nptrs = 0 vt_info(nv,igr)%var_len_global = var_len_global - nullify(vt_info(nv,igr)%vt_vector) + vt_info(nv,igr)%vector_allocated = .true. allocate(vt_info(nv,igr)%vt_vector(max_ptrs)) read(tokens(2),fmt=*) vt_info(nv,igr)%idim_type @@ -280,7 +283,7 @@ recursive subroutine vtable_edio_r(npts,var,nv,igr,init,glob_id,var_len,var_len_ ! init = 0 then do this part. Since I think this should never happen, I will ! ! also make a fuss to warn the user. ! !---------------------------------------------------------------------------------! - if (.not.associated(vt_info(nv,igr)%vt_vector)) then + if (.not. vt_info(nv,igr)%vector_allocated) then write (unit=*,fmt='(a)') ' ' write (unit=*,fmt='(a)') '----------------------------------------------' write (unit=*,fmt='(a)') ' WARNING! WARNING! WARNING! WARNING! WARNING! ' @@ -290,7 +293,7 @@ recursive subroutine vtable_edio_r(npts,var,nv,igr,init,glob_id,var_len,var_len_ write (unit=*,fmt='(a)') ' - Subroutine vtable_edio_r (file ed_var_tables.f90)' write (unit=*,fmt='(a,1x,i4,1x,a,1x,i2,1x,a)') & ' - Vt_vector for variable',nv,'of grid',igr & - ,'is not associated !' + ,'is not allocated !' write (unit=*,fmt='(a)') ' - I will allocate it now.' write (unit=*,fmt='(a,1x,i20,1x,a)') ' - MAX_PTRS=',max_ptrs,'...' write (unit=*,fmt='(a,1x,a,1x,a)') ' - Tabstr=',tabstr,'...' @@ -367,6 +370,9 @@ recursive subroutine vtable_edio_d(npts,var,nv,igr,init,glob_id,var_len,var_len_ ! follow. ! !------------------------------------------------------------------------------------! if (init == 0) then + !----- Make sure we have a clean start. ------------------------------------------! + call reset_vt_vector_pointers(vt_info(nv,igr)) + !---------------------------------------------------------------------------------! !----- Count the number of variables. --------------------------------------------! num_var(igr) = num_var(igr) + 1 @@ -377,7 +383,7 @@ recursive subroutine vtable_edio_d(npts,var,nv,igr,init,glob_id,var_len,var_len_ vt_info(nv,igr)%nptrs = 0 vt_info(nv,igr)%var_len_global = var_len_global - nullify(vt_info(nv,igr)%vt_vector) + vt_info(nv,igr)%vector_allocated = .true. allocate(vt_info(nv,igr)%vt_vector(max_ptrs)) read(tokens(2),fmt=*) vt_info(nv,igr)%idim_type @@ -450,7 +456,7 @@ recursive subroutine vtable_edio_d(npts,var,nv,igr,init,glob_id,var_len,var_len_ ! init = 0 then do this part. Since I think this should never happen, I will ! ! also make a fuss to warn the user. ! !---------------------------------------------------------------------------------! - if (.not.associated(vt_info(nv,igr)%vt_vector)) then + if (.not. vt_info(nv,igr)%vector_allocated) then write (unit=*,fmt='(a)') ' ' write (unit=*,fmt='(a)') '----------------------------------------------' write (unit=*,fmt='(a)') ' WARNING! WARNING! WARNING! WARNING! WARNING! ' @@ -460,7 +466,7 @@ recursive subroutine vtable_edio_d(npts,var,nv,igr,init,glob_id,var_len,var_len_ write (unit=*,fmt='(a)') ' - Subroutine vtable_edio_r (file ed_var_tables.f90)' write (unit=*,fmt='(a,1x,i4,1x,a,1x,i2,1x,a)') & ' - Vt_vector for variable',nv,'of grid',igr & - ,'is not associated !' + ,'is not allocated !' write (unit=*,fmt='(a)') ' - I will allocate it now.' write (unit=*,fmt='(a,1x,i20,1x,a)') ' - MAX_PTRS=',max_ptrs,'...' write (unit=*,fmt='(a,1x,a,1x,a)') ' - Tabstr=',tabstr,'...' @@ -536,6 +542,9 @@ recursive subroutine vtable_edio_i(npts,var,nv,igr,init,glob_id,var_len,var_len_ ! follow. ! !------------------------------------------------------------------------------------! if (init == 0) then + !----- Make sure we have a clean start. ------------------------------------------! + call reset_vt_vector_pointers(vt_info(nv,igr)) + !---------------------------------------------------------------------------------! !----- Count the number of variables. --------------------------------------------! num_var(igr) = num_var(igr) + 1 @@ -546,7 +555,7 @@ recursive subroutine vtable_edio_i(npts,var,nv,igr,init,glob_id,var_len,var_len_ vt_info(nv,igr)%nptrs = 0 vt_info(nv,igr)%var_len_global = var_len_global - nullify(vt_info(nv,igr)%vt_vector) + vt_info(nv,igr)%vector_allocated = .true. allocate(vt_info(nv,igr)%vt_vector(max_ptrs)) read(tokens(2),fmt=*) vt_info(nv,igr)%idim_type @@ -619,7 +628,7 @@ recursive subroutine vtable_edio_i(npts,var,nv,igr,init,glob_id,var_len,var_len_ ! init = 0 then do this part. Since I think this should never happen, I will ! ! also make a fuss to warn the user. ! !---------------------------------------------------------------------------------! - if (.not.associated(vt_info(nv,igr)%vt_vector)) then + if (.not. vt_info(nv,igr)%vector_allocated) then write (unit=*,fmt='(a)') ' ' write (unit=*,fmt='(a)') '----------------------------------------------' write (unit=*,fmt='(a)') ' WARNING! WARNING! WARNING! WARNING! WARNING! ' @@ -629,7 +638,7 @@ recursive subroutine vtable_edio_i(npts,var,nv,igr,init,glob_id,var_len,var_len_ write (unit=*,fmt='(a)') ' - Subroutine vtable_edio_r (file ed_var_tables.f90)' write (unit=*,fmt='(a,1x,i4,1x,a,1x,i2,1x,a)') & ' - Vt_vector for variable',nv,'of grid',igr & - ,'is not associated !' + ,'is not allocated !' write (unit=*,fmt='(a)') ' - I will allocate it now.' write (unit=*,fmt='(a,1x,i20,1x,a)') ' - MAX_PTRS=',max_ptrs,'...' write (unit=*,fmt='(a,1x,a,1x,a)') ' - Tabstr=',tabstr,'...' @@ -705,6 +714,9 @@ recursive subroutine vtable_edio_c(npts,var,nv,igr,init,glob_id,var_len,var_len_ ! follow. ! !------------------------------------------------------------------------------------! if (init == 0) then + !----- Make sure we have a clean start. ------------------------------------------! + call reset_vt_vector_pointers(vt_info(nv,igr)) + !---------------------------------------------------------------------------------! !----- Count the number of variables. --------------------------------------------! num_var(igr) = num_var(igr) + 1 @@ -715,7 +727,7 @@ recursive subroutine vtable_edio_c(npts,var,nv,igr,init,glob_id,var_len,var_len_ vt_info(nv,igr)%nptrs = 0 vt_info(nv,igr)%var_len_global = var_len_global - nullify(vt_info(nv,igr)%vt_vector) + vt_info(nv,igr)%vector_allocated = .true. allocate(vt_info(nv,igr)%vt_vector(max_ptrs)) read(tokens(2),fmt=*) vt_info(nv,igr)%idim_type @@ -788,7 +800,7 @@ recursive subroutine vtable_edio_c(npts,var,nv,igr,init,glob_id,var_len,var_len_ ! init = 0 then do this part. Since I think this should never happen, I will ! ! also make a fuss to warn the user. ! !---------------------------------------------------------------------------------! - if (.not.associated(vt_info(nv,igr)%vt_vector)) then + if (.not. vt_info(nv,igr)%vector_allocated) then write (unit=*,fmt='(a)') ' ' write (unit=*,fmt='(a)') '----------------------------------------------' write (unit=*,fmt='(a)') ' WARNING! WARNING! WARNING! WARNING! WARNING! ' @@ -798,7 +810,7 @@ recursive subroutine vtable_edio_c(npts,var,nv,igr,init,glob_id,var_len,var_len_ write (unit=*,fmt='(a)') ' - Subroutine vtable_edio_r (file ed_var_tables.f90)' write (unit=*,fmt='(a,1x,i4,1x,a,1x,i2,1x,a)') & ' - Vt_vector for variable',nv,'of grid',igr & - ,'is not associated !' + ,'is not allocated !' write (unit=*,fmt='(a)') ' - I will allocate it now.' write (unit=*,fmt='(a,1x,i20,1x,a)') ' - MAX_PTRS=',max_ptrs,'...' write (unit=*,fmt='(a,1x,a,1x,a)') ' - Tabstr=',tabstr,'...' @@ -872,6 +884,9 @@ recursive subroutine vtable_edio_r_sca(var,nv,igr,init,glob_id,var_len,var_len_g ! follow. ! !------------------------------------------------------------------------------------! if (init == 0) then + !----- Make sure we have a clean start. ------------------------------------------! + call reset_vt_vector_pointers(vt_info(nv,igr)) + !---------------------------------------------------------------------------------! !----- Count the number of variables. --------------------------------------------! num_var(igr) = num_var(igr) + 1 @@ -882,7 +897,7 @@ recursive subroutine vtable_edio_r_sca(var,nv,igr,init,glob_id,var_len,var_len_g vt_info(nv,igr)%nptrs = 0 vt_info(nv,igr)%var_len_global = var_len_global - nullify(vt_info(nv,igr)%vt_vector) + vt_info(nv,igr)%vector_allocated = .true. allocate(vt_info(nv,igr)%vt_vector(max_ptrs)) read(tokens(2),fmt=*) vt_info(nv,igr)%idim_type @@ -955,7 +970,7 @@ recursive subroutine vtable_edio_r_sca(var,nv,igr,init,glob_id,var_len,var_len_g ! init = 0 then do this part. Since I think this should never happen, I will ! ! also make a fuss to warn the user. ! !---------------------------------------------------------------------------------! - if (.not.associated(vt_info(nv,igr)%vt_vector)) then + if (.not. vt_info(nv,igr)%vector_allocated) then write (unit=*,fmt='(a)') ' ' write (unit=*,fmt='(a)') '----------------------------------------------' write (unit=*,fmt='(a)') ' WARNING! WARNING! WARNING! WARNING! WARNING! ' @@ -965,7 +980,7 @@ recursive subroutine vtable_edio_r_sca(var,nv,igr,init,glob_id,var_len,var_len_g write (unit=*,fmt='(a)') ' - Subroutine vtable_edio_r (file ed_var_tables.f90)' write (unit=*,fmt='(a,1x,i4,1x,a,1x,i2,1x,a)') & ' - Vt_vector for variable',nv,'of grid',igr & - ,'is not associated !' + ,'is not allocated !' write (unit=*,fmt='(a)') ' - I will allocate it now.' write (unit=*,fmt='(a,1x,i20,1x,a)') ' - MAX_PTRS=',max_ptrs,'...' write (unit=*,fmt='(a,1x,a,1x,a)') ' - Tabstr=',tabstr,'...' @@ -1040,6 +1055,9 @@ recursive subroutine vtable_edio_d_sca(var,nv,igr,init,glob_id,var_len,var_len_g ! follow. ! !------------------------------------------------------------------------------------! if (init == 0) then + !----- Make sure we have a clean start. ------------------------------------------! + call reset_vt_vector_pointers(vt_info(nv,igr)) + !---------------------------------------------------------------------------------! !----- Count the number of variables. --------------------------------------------! num_var(igr) = num_var(igr) + 1 @@ -1050,7 +1068,7 @@ recursive subroutine vtable_edio_d_sca(var,nv,igr,init,glob_id,var_len,var_len_g vt_info(nv,igr)%nptrs = 0 vt_info(nv,igr)%var_len_global = var_len_global - nullify(vt_info(nv,igr)%vt_vector) + vt_info(nv,igr)%vector_allocated = .true. allocate(vt_info(nv,igr)%vt_vector(max_ptrs)) read(tokens(2),fmt=*) vt_info(nv,igr)%idim_type @@ -1123,7 +1141,7 @@ recursive subroutine vtable_edio_d_sca(var,nv,igr,init,glob_id,var_len,var_len_g ! init = 0 then do this part. Since I think this should never happen, I will ! ! also make a fuss to warn the user. ! !---------------------------------------------------------------------------------! - if (.not.associated(vt_info(nv,igr)%vt_vector)) then + if (.not. vt_info(nv,igr)%vector_allocated) then write (unit=*,fmt='(a)') ' ' write (unit=*,fmt='(a)') '----------------------------------------------' write (unit=*,fmt='(a)') ' WARNING! WARNING! WARNING! WARNING! WARNING! ' @@ -1133,7 +1151,7 @@ recursive subroutine vtable_edio_d_sca(var,nv,igr,init,glob_id,var_len,var_len_g write (unit=*,fmt='(a)') ' - Subroutine vtable_edio_r (file ed_var_tables.f90)' write (unit=*,fmt='(a,1x,i4,1x,a,1x,i2,1x,a)') & ' - Vt_vector for variable',nv,'of grid',igr & - ,'is not associated !' + ,'is not allocated !' write (unit=*,fmt='(a)') ' - I will allocate it now.' write (unit=*,fmt='(a,1x,i20,1x,a)') ' - MAX_PTRS=',max_ptrs,'...' write (unit=*,fmt='(a,1x,a,1x,a)') ' - Tabstr=',tabstr,'...' @@ -1207,6 +1225,9 @@ recursive subroutine vtable_edio_i_sca(var,nv,igr,init,glob_id,var_len,var_len_g ! follow. ! !------------------------------------------------------------------------------------! if (init == 0) then + !----- Make sure we have a clean start. ------------------------------------------! + call reset_vt_vector_pointers(vt_info(nv,igr)) + !---------------------------------------------------------------------------------! !----- Count the number of variables. --------------------------------------------! num_var(igr) = num_var(igr) + 1 @@ -1217,7 +1238,7 @@ recursive subroutine vtable_edio_i_sca(var,nv,igr,init,glob_id,var_len,var_len_g vt_info(nv,igr)%nptrs = 0 vt_info(nv,igr)%var_len_global = var_len_global - nullify(vt_info(nv,igr)%vt_vector) + vt_info(nv,igr)%vector_allocated = .true. allocate(vt_info(nv,igr)%vt_vector(max_ptrs)) read(tokens(2),fmt=*) vt_info(nv,igr)%idim_type @@ -1290,7 +1311,7 @@ recursive subroutine vtable_edio_i_sca(var,nv,igr,init,glob_id,var_len,var_len_g ! init = 0 then do this part. Since I think this should never happen, I will ! ! also make a fuss to warn the user. ! !---------------------------------------------------------------------------------! - if (.not.associated(vt_info(nv,igr)%vt_vector)) then + if (.not. vt_info(nv,igr)%vector_allocated) then write (unit=*,fmt='(a)') ' ' write (unit=*,fmt='(a)') '----------------------------------------------' write (unit=*,fmt='(a)') ' WARNING! WARNING! WARNING! WARNING! WARNING! ' @@ -1300,7 +1321,7 @@ recursive subroutine vtable_edio_i_sca(var,nv,igr,init,glob_id,var_len,var_len_g write (unit=*,fmt='(a)') ' - Subroutine vtable_edio_r (file ed_var_tables.f90)' write (unit=*,fmt='(a,1x,i4,1x,a,1x,i2,1x,a)') & ' - Vt_vector for variable',nv,'of grid',igr & - ,'is not associated !' + ,'is not allocated !' write (unit=*,fmt='(a)') ' - I will allocate it now.' write (unit=*,fmt='(a,1x,i20,1x,a)') ' - MAX_PTRS=',max_ptrs,'...' write (unit=*,fmt='(a,1x,a,1x,a)') ' - Tabstr=',tabstr,'...' @@ -1374,6 +1395,9 @@ recursive subroutine vtable_edio_c_sca(var,nv,igr,init,glob_id,var_len,var_len_g ! follow. ! !------------------------------------------------------------------------------------! if (init == 0) then + !----- Make sure we have a clean start. ------------------------------------------! + call reset_vt_vector_pointers(vt_info(nv,igr)) + !---------------------------------------------------------------------------------! !----- Count the number of variables. --------------------------------------------! num_var(igr) = num_var(igr) + 1 @@ -1384,7 +1408,7 @@ recursive subroutine vtable_edio_c_sca(var,nv,igr,init,glob_id,var_len,var_len_g vt_info(nv,igr)%nptrs = 0 vt_info(nv,igr)%var_len_global = var_len_global - nullify(vt_info(nv,igr)%vt_vector) + vt_info(nv,igr)%vector_allocated = .true. allocate(vt_info(nv,igr)%vt_vector(max_ptrs)) read(tokens(2),fmt=*) vt_info(nv,igr)%idim_type @@ -1457,7 +1481,7 @@ recursive subroutine vtable_edio_c_sca(var,nv,igr,init,glob_id,var_len,var_len_g ! init = 0 then do this part. Since I think this should never happen, I will ! ! also make a fuss to warn the user. ! !---------------------------------------------------------------------------------! - if (.not.associated(vt_info(nv,igr)%vt_vector)) then + if (.not. vt_info(nv,igr)%vector_allocated) then write (unit=*,fmt='(a)') ' ' write (unit=*,fmt='(a)') '----------------------------------------------' write (unit=*,fmt='(a)') ' WARNING! WARNING! WARNING! WARNING! WARNING! ' @@ -1467,7 +1491,7 @@ recursive subroutine vtable_edio_c_sca(var,nv,igr,init,glob_id,var_len,var_len_g write (unit=*,fmt='(a)') ' - Subroutine vtable_edio_r (file ed_var_tables.f90)' write (unit=*,fmt='(a,1x,i4,1x,a,1x,i2,1x,a)') & ' - Vt_vector for variable',nv,'of grid',igr & - ,'is not associated !' + ,'is not allocated !' write (unit=*,fmt='(a)') ' - I will allocate it now.' write (unit=*,fmt='(a,1x,i20,1x,a)') ' - MAX_PTRS=',max_ptrs,'...' write (unit=*,fmt='(a,1x,a,1x,a)') ' - Tabstr=',tabstr,'...' @@ -1520,16 +1544,52 @@ end subroutine metadata_edio !=======================================================================================! !=======================================================================================! - subroutine nullify_vt_vector_pointers(vt_vec) + ! This subroutine unlinks all pointers then deallocate the vector, for a safe re- ! + ! allocation. ! + !---------------------------------------------------------------------------------------! + subroutine reset_vt_vector_pointers(vt) implicit none - type(var_table_vector), target :: vt_vec - - if (associated(vt_vec%var_rp)) nullify(vt_vec%var_rp) - if (associated(vt_vec%var_ip)) nullify(vt_vec%var_ip) - if (associated(vt_vec%var_cp)) nullify(vt_vec%var_cp) - if (associated(vt_vec%var_dp)) nullify(vt_vec%var_dp) + !----- Arguments. -------------------------------------------------------------------! + type(var_table), intent(inout) :: vt + !----- Local variables. -------------------------------------------------------------! + integer :: iptr + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! I actually don't know why, but the typical "if (allocated(vt%vt_vector))" ! + ! doesn't work here, so instead we save a logical test... ! + !------------------------------------------------------------------------------------! + if (.not. vt%vector_allocated) return + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Go through all pointer elements and nullify those associated with variables. ! + ! We must do that before we deallocate so only the pointers, not the true arrays, ! + ! are deallocated. ! + !------------------------------------------------------------------------------------! + do iptr=1,vt%nptrs + if (associated(vt%vt_vector(iptr)%var_rp)) nullify(vt%vt_vector(iptr)%var_rp) + if (associated(vt%vt_vector(iptr)%var_ip)) nullify(vt%vt_vector(iptr)%var_ip) + if (associated(vt%vt_vector(iptr)%var_cp)) nullify(vt%vt_vector(iptr)%var_cp) + if (associated(vt%vt_vector(iptr)%var_dp)) nullify(vt%vt_vector(iptr)%var_dp) + if (associated(vt%vt_vector(iptr)%sca_rp)) nullify(vt%vt_vector(iptr)%sca_rp) + if (associated(vt%vt_vector(iptr)%sca_ip)) nullify(vt%vt_vector(iptr)%sca_ip) + if (associated(vt%vt_vector(iptr)%sca_cp)) nullify(vt%vt_vector(iptr)%sca_cp) + if (associated(vt%vt_vector(iptr)%sca_dp)) nullify(vt%vt_vector(iptr)%sca_dp) + end do + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Now it's safe to deallocate, just remind to update the logical flag... ! + !------------------------------------------------------------------------------------! + deallocate(vt%vt_vector) + vt%vector_allocated = .false. + !------------------------------------------------------------------------------------! + return - end subroutine nullify_vt_vector_pointers + end subroutine reset_vt_vector_pointers !=======================================================================================! !=======================================================================================! end module ed_var_tables diff --git a/ED/src/memory/ename_coms.f90 b/ED/src/memory/ename_coms.f90 index 37a9d2d17..0deb6d90b 100644 --- a/ED/src/memory/ename_coms.f90 +++ b/ED/src/memory/ename_coms.f90 @@ -131,6 +131,7 @@ module ename_coms !----- Options for model dynamics. --------------------------------------------------! integer :: ivegt_dynamics + integer :: ibigleaf integer :: integration_scheme real :: rk4_tolerance integer :: ibranch_thermo @@ -180,6 +181,7 @@ module ename_coms integer :: n_decomp_lim integer :: decomp_scheme integer :: include_fire + real :: fire_parameter real :: sm_fire integer :: ianth_disturb integer :: icanturb @@ -232,11 +234,16 @@ module ename_coms character(len=str_len) :: phenpath character(len=str_len) :: event_file + !----- Variables to control detailed output. ----------------------------------------! + integer :: idetailed + integer :: patch_keep + !----- Variables that control the sought number of patches and cohorts. -------------! integer :: maxsite integer :: maxpatch integer :: maxcohort real :: min_site_area + real :: min_patch_area !----- Directory for optimizer inputs. ----------------------------------------------! character(len=str_len) :: ioptinpt @@ -378,6 +385,7 @@ subroutine init_ename_vars(enl) enl%ivegt_dynamics = undef_integer + enl%ibigleaf = undef_integer enl%integration_scheme = undef_integer enl%rk4_tolerance = undef_real enl%ibranch_thermo = undef_integer @@ -427,6 +435,7 @@ subroutine init_ename_vars(enl) enl%n_decomp_lim = undef_integer enl%decomp_scheme = undef_integer enl%include_fire = undef_integer + enl%fire_parameter = undef_real enl%sm_fire = undef_real enl%ianth_disturb = undef_integer enl%icanturb = undef_integer @@ -476,10 +485,14 @@ subroutine init_ename_vars(enl) enl%phenpath = undef_path enl%event_file = undef_path + enl%idetailed = undef_integer + enl%patch_keep = undef_integer + enl%maxsite = undef_integer enl%maxpatch = undef_integer enl%maxcohort = undef_integer enl%min_site_area = undef_real + enl%min_patch_area = undef_real enl%ioptinpt = undef_path enl%zrough = undef_real diff --git a/ED/src/memory/pft_coms.f90 b/ED/src/memory/pft_coms.f90 index e5a09d2b2..dc498d3bf 100644 --- a/ED/src/memory/pft_coms.f90 +++ b/ED/src/memory/pft_coms.f90 @@ -487,12 +487,16 @@ module pft_coms !---------------------------------------------------------------------------------------! !----- Initial plant density in a near-bare-ground run [plant/m²]. ---------------------! real , dimension(n_pft) :: init_density + !----- Initial maximum LAI in a near-bare-ground run [m²/m²] - Big leaf only. ----------! + real , dimension(n_pft) :: init_laimax !----- Minimum height of an individual [m]. --------------------------------------------! real , dimension(n_pft) :: hgt_min !----- Maximum height of an individual [m]. --------------------------------------------! real , dimension(n_pft) :: hgt_max !----- Minimum biomass density [kgC/m²] required to form a new recruit. ----------------! real , dimension(n_pft) :: min_recruit_size + !----- Amount of biomass [kgC] in one tree, used for 'big-leaf' ED. --------------------! + real , dimension(n_pft) :: one_plant_c !---------------------------------------------------------------------------------------! ! Fraction of (positive) carbon balance devoted to storage (unwise to set this to ! ! anything other than zero unless storage turnover rate is adjusted accordingly). ! @@ -540,12 +544,15 @@ module pft_coms !=======================================================================================! !=======================================================================================! - ! The following varible is used to "turn off" the lights for extremely sparse ! - ! cohorts, that otherwise can have strange light values due to numeric precision. This ! - ! will cause the cohort to starve to death, and it will be quickly eliminated. ! + ! The following varible will be used to "turn off" the biophysics for extremely low ! + ! biomass cohorts, that otherwise could shrink the time step in case they were solved. ! + ! We use heat capacity rather than leaf/wood area index as the threshold because the ! + ! heat capacity what will control the time step. Also, in case of leaves, the bio- ! + ! physics "turn off" will kill the cohorts, because they won't be able to do photo- ! + ! synthesis. ! !=======================================================================================! !=======================================================================================! - real, dimension(n_pft) :: lai_min + real, dimension(n_pft) :: veg_hcap_min !=======================================================================================! !=======================================================================================! @@ -574,13 +581,22 @@ module pft_coms !---------------------------------------------------------------------------------------! type recruittype integer :: pft + integer :: krdepth + integer :: phenology_status real :: leaf_temp real :: wood_temp + real :: leaf_temp_pv + real :: wood_temp_pv real :: hite real :: dbh real :: bdead real :: bleaf + real :: broot + real :: bsapwood real :: balive + real :: paw_avg + real :: elongf + real :: bstorage real :: nplant end type recruittype !=======================================================================================! @@ -605,16 +621,25 @@ subroutine zero_recruit(maxp,recruit) !------------------------------------------------------------------------------------! do p=1,maxp - recruit(p)%pft = 0 - recruit(p)%leaf_temp = 0. - recruit(p)%wood_temp = 0. - recruit(p)%hite = 0. - recruit(p)%dbh = 0. - recruit(p)%bdead = 0. - recruit(p)%bleaf = 0. - recruit(p)%balive = 0. - recruit(p)%nplant = 0. - end do + recruit(p)%pft = 0 + recruit(p)%krdepth = 0 + recruit(p)%phenology_status = 0 + recruit(p)%leaf_temp = 0. + recruit(p)%wood_temp = 0. + recruit(p)%leaf_temp_pv = 0. + recruit(p)%wood_temp_pv = 0. + recruit(p)%hite = 0. + recruit(p)%dbh = 0. + recruit(p)%bdead = 0. + recruit(p)%bleaf = 0. + recruit(p)%broot = 0. + recruit(p)%bsapwood = 0. + recruit(p)%balive = 0. + recruit(p)%paw_avg = 0. + recruit(p)%elongf = 0. + recruit(p)%bstorage = 0. + recruit(p)%nplant = 0. + end do return end subroutine zero_recruit @@ -637,15 +662,24 @@ subroutine copy_recruit(recsource,rectarget) type(recruittype), intent(out) :: rectarget !------------------------------------------------------------------------------------! - rectarget%pft = recsource%pft - rectarget%leaf_temp = recsource%leaf_temp - rectarget%wood_temp = recsource%wood_temp - rectarget%hite = recsource%hite - rectarget%dbh = recsource%dbh - rectarget%bdead = recsource%bdead - rectarget%bleaf = recsource%bleaf - rectarget%balive = recsource%balive - rectarget%nplant = recsource%nplant + rectarget%pft = recsource%pft + rectarget%krdepth = recsource%krdepth + rectarget%phenology_status = recsource%phenology_status + rectarget%leaf_temp = recsource%leaf_temp + rectarget%wood_temp = recsource%wood_temp + rectarget%leaf_temp_pv = recsource%leaf_temp_pv + rectarget%wood_temp_pv = recsource%wood_temp_pv + rectarget%hite = recsource%hite + rectarget%dbh = recsource%dbh + rectarget%bdead = recsource%bdead + rectarget%bleaf = recsource%bleaf + rectarget%broot = recsource%broot + rectarget%bsapwood = recsource%bsapwood + rectarget%balive = recsource%balive + rectarget%paw_avg = recsource%paw_avg + rectarget%elongf = recsource%elongf + rectarget%bstorage = recsource%bstorage + rectarget%nplant = recsource%nplant return end subroutine copy_recruit diff --git a/ED/src/memory/rk4_coms.f90 b/ED/src/memory/rk4_coms.f90 index 4cc2c1eef..7b033a540 100644 --- a/ED/src/memory/rk4_coms.f90 +++ b/ED/src/memory/rk4_coms.f90 @@ -23,19 +23,18 @@ module rk4_coms type rk4patchtype !----- Canopy air variables. --------------------------------------------------------! - real(kind=8) :: can_theiv ! Eq. pot. temperature [ K] - real(kind=8) :: can_lntheta ! Log (theta) [ ---] + real(kind=8) :: can_enthalpy ! Canopy sp. enthalpy [ J/kg] real(kind=8) :: can_theta ! Pot. Temperature [ K] real(kind=8) :: can_temp ! Temperature [ K] real(kind=8) :: can_shv ! Specific humidity [ kg/kg] real(kind=8) :: can_ssh ! Sat. spec. humidity [ kg/kg] - real(kind=8) :: can_rvap ! Vapour mixing ratio [ kg/kg] real(kind=8) :: can_rhv ! Relative humidity [ ---] real(kind=8) :: can_co2 ! CO_2 [µmol/mol] real(kind=8) :: can_depth ! Canopy depth [ m] real(kind=8) :: can_rhos ! Canopy air density [ kg/m³] real(kind=8) :: can_prss ! Pressure [ Pa] real(kind=8) :: can_exner ! Exner function [ J/kg/K] + real(kind=8) :: can_cp ! Specific heat [ J/kg/K] !------------------------------------------------------------------------------------! @@ -205,12 +204,11 @@ module rk4_coms real(kind=8), pointer, dimension(:) :: veg_wind ! Cohort-level wind [ m/s] real(kind=8), pointer, dimension(:) :: lai ! Leaf area index [ m²/m²] real(kind=8), pointer, dimension(:) :: wai ! Wood area index [ m²/m²] - real(kind=8), pointer, dimension(:) :: wpa ! Wood projected area [ m²/m²] real(kind=8), pointer, dimension(:) :: tai ! Tree area index [ m²/m²] real(kind=8), pointer, dimension(:) :: crown_area ! Crown area [ m²/m²] real(kind=8), pointer, dimension(:) :: elongf ! Elongation factor [ ----] - real(kind=8), pointer, dimension(:) :: psi_open ! Water demand (op.) [ kg/m²/s] - real(kind=8), pointer, dimension(:) :: psi_closed ! Water demand (clos.)[ kg/m²/s] + real(kind=8), pointer, dimension(:) :: psi_open ! Water demand (op.) [kg/m²lf/s] + real(kind=8), pointer, dimension(:) :: psi_closed ! Water demand (clos.)[kg/m²lf/s] real(kind=8), pointer, dimension(:) :: fs_open ! Frac. of op. stom. [ ---] real(kind=8), pointer, dimension(:) :: gpp ! Gross primary prod. [µmol/m²/s] real(kind=8), pointer, dimension(:) :: leaf_resp ! Leaf respiration [µmol/m²/s] @@ -218,7 +216,17 @@ module rk4_coms real(kind=8), pointer, dimension(:) :: growth_resp ! Growth respiration [µmol/m²/s] real(kind=8), pointer, dimension(:) :: storage_resp ! Storage respiration [µmol/m²/s] real(kind=8), pointer, dimension(:) :: vleaf_resp ! Virtual leaf resp. [µmol/m²/s] - !------------------------------------------------------------------------------------! + + + !------ Variables used for hybrid stepping -----------------------------------------! + real(kind=8) :: wflxgc + real(kind=8) :: wflxac + real(kind=8), pointer, dimension(:) :: wflxtr + real(kind=8), pointer, dimension(:) :: wflxlc + real(kind=8), pointer, dimension(:) :: wflxwc + real(kind=8), pointer, dimension(:) :: hflx_lrsti ! heat gained from rnet,shed,tr,int + real(kind=8), pointer, dimension(:) :: hflx_wrsti ! + !-----------------------------------------------------------------------------------! @@ -313,6 +321,7 @@ module rk4_coms real(kind=8) :: co2budget_storage real(kind=8) :: co2budget_loss2atm real(kind=8) :: ebudget_storage + real(kind=8) :: ebudget_netrad real(kind=8) :: ebudget_loss2atm real(kind=8) :: ebudget_loss2drainage real(kind=8) :: ebudget_loss2runoff @@ -323,6 +332,13 @@ module rk4_coms end type rk4patchtype !---------------------------------------------------------------------------------------! + + type bdf2patchtype + real(kind=8) :: can_temp + real(kind=8),pointer,dimension(:) :: leaf_temp + real(kind=8),pointer,dimension(:) :: wood_temp + end type bdf2patchtype + !---------------------------------------------------------------------------------------! ! Structure with atmospheric and some other site-level data that is often used ! @@ -334,12 +350,12 @@ module rk4_coms real(kind=8), dimension(n_pft) :: green_leaf_factor real(kind=8) :: atm_rhos real(kind=8) :: vels + real(kind=8) :: atm_enthalpy + real(kind=8) :: atm_tmp_zcan real(kind=8) :: atm_tmp real(kind=8) :: atm_theta real(kind=8) :: atm_theiv - real(kind=8) :: atm_lntheta real(kind=8) :: atm_shv - real(kind=8) :: atm_rvap real(kind=8) :: atm_rhv real(kind=8) :: atm_co2 real(kind=8) :: zoff @@ -369,28 +385,28 @@ module rk4_coms !---------------------------------------------------------------------------------------! type rk4auxtype !----- Total potential [m]. ---------------------------------------------------------! - real(kind=8), dimension(:), pointer :: psiplusz + real(kind=8), dimension(:) , pointer :: psiplusz !----- Hydraulic conductivity [m/s]. ------------------------------------------------! - real(kind=8), dimension(:), pointer :: hydcond + real(kind=8), dimension(:) , pointer :: hydcond !----- Available water factor at this layer [n/d]. ----------------------------------! - real(kind=8), dimension(:), pointer :: avail_h2o_lyr + real(kind=8), dimension(:) , pointer :: avail_h2o_lyr !----- Integral of available water factor from top to this layer [n/d]. -------------! - real(kind=8), dimension(:), pointer :: avail_h2o_int + real(kind=8), dimension(:) , pointer :: avail_h2o_int !----- Extracted water by transpiration [kg/m²]. ------------------------------------! - real(kind=8), dimension(:), pointer :: extracted_water + real(kind=8), dimension(:,:), pointer :: extracted_water !----- Heat resistance [Km²s/J]. ----------------------------------------------------! - real(kind=8), dimension(:), pointer :: rfactor + real(kind=8), dimension(:) , pointer :: rfactor !----- Sensible heat flux at staggered layer (k = k-1/2) [W/m²]. --------------------! - real(kind=8), dimension(:), pointer :: hfluxgsc + real(kind=8), dimension(:) , pointer :: hfluxgsc !----- Water flux at staggered layers (k = k-1/2) [kg/m²/s]. ------------------------! - real(kind=8), dimension(:), pointer :: w_flux + real(kind=8), dimension(:) , pointer :: w_flux !----- Latent heat flux at staggered layers (k=k-1/2) [W/m²]. -----------------------! - real(kind=8), dimension(:), pointer :: qw_flux + real(kind=8), dimension(:) , pointer :: qw_flux !----- Depth flux at staggered layers (k=k-1/2) [m/s]. ------------------------------! - real(kind=8), dimension(:), pointer :: d_flux + real(kind=8), dimension(:) , pointer :: d_flux !----- Tests to check if the soil is too dry or too wet. ----------------------------! - logical , dimension(:), pointer :: drysoil - logical , dimension(:), pointer :: satsoil + logical , dimension(:) , pointer :: drysoil + logical , dimension(:) , pointer :: satsoil end type rk4auxtype !---------------------------------------------------------------------------------------! @@ -413,6 +429,7 @@ module rk4_coms type(rk4patchtype), pointer :: ak5 ! type(rk4patchtype), pointer :: ak6 ! type(rk4patchtype), pointer :: ak7 ! + type(bdf2patchtype), pointer :: yprev ! Previous state end type integration_vars !---------------------------------------------------------------------------------------! @@ -425,10 +442,6 @@ module rk4_coms !=======================================================================================! - - - - !=======================================================================================! !=======================================================================================! ! The following variable will be loaded from the user's namelist. ! @@ -581,6 +594,8 @@ module rk4_coms ! accross months, as the patches change. logical :: print_thbnd ! Flag to keep track of which variable is causing the ! most errors in the integrator. + logical :: print_budget ! Flag that tells whether the budget is to be printed + ! to a file. !---------------------------------------------------------------------------------------! @@ -593,13 +608,6 @@ module rk4_coms ! supersat_ok is .false., but in this case ! only mixing with free atmosphere can cause ! the super-saturation). - logical :: force_idealgas ! The integrator will adjust pressure every time - ! step, including the internal ones, to make - ! sure the ideal gas is respected. If set to - ! false, it will keep pressure constant - ! within on DTLSM time step, and not bother - ! forcing the canopy air space to respect the - ! ideal gas [ T|F] logical :: leaf_intercept ! This flag is to turn on and on the leaf interception. ! Except for developer tests, this variable should be ! always true. @@ -624,8 +632,6 @@ module rk4_coms real(kind=8) :: rk4max_can_temp ! Maximum canopy temperature [ K] real(kind=8) :: rk4min_can_shv ! Minimum canopy specific humidity [kg/kg_air] real(kind=8) :: rk4max_can_shv ! Maximum canopy specific humidity [kg/kg_air] - real(kind=8) :: rk4min_can_rvap ! Minimum canopy mixing ratio [kg/kg_air] - real(kind=8) :: rk4max_can_rvap ! Maximum canopy mixing ratio [kg/kg_air] real(kind=8) :: rk4min_can_rhv ! Minimum canopy relative humidity [ ---] real(kind=8) :: rk4max_can_rhv ! Maximum canopy relative humidity [ ---] real(kind=8) :: rk4min_can_co2 ! Minimum canopy CO2 mixing ratio [ µmol/mol] @@ -646,10 +652,8 @@ module rk4_coms !----- The following variables will be defined every time step. ------------------------! real(kind=8) :: rk4min_can_theta ! Minimum canopy potential temp. [ K] real(kind=8) :: rk4max_can_theta ! Maximum canopy potential temp. [ K] - real(kind=8) :: rk4min_can_lntheta ! Minimum canopy log of theta [ ---] - real(kind=8) :: rk4max_can_lntheta ! Maximum canopy log of theta [ ---] - real(kind=8) :: rk4min_can_theiv ! Minimum canopy eq. pot. temp. [ K] - real(kind=8) :: rk4max_can_theiv ! Maximum canopy eq. pot. temp. [ K] + real(kind=8) :: rk4min_can_enthalpy ! Minimum canopy enthalpy [ J/m2] + real(kind=8) :: rk4max_can_enthalpy ! Maximum canopy enthalpy [ J/m2] real(kind=8) :: rk4min_can_prss ! Minimum canopy pressure [ Pa] real(kind=8) :: rk4max_can_prss ! Maximum canopy pressure [ Pa] !---------------------------------------------------------------------------------------! @@ -721,20 +725,29 @@ module rk4_coms ! Flag to determine whether the patch is too sparsely populated to be computed at ! ! the cohort level. The decision is made based on the difference in order of magnitude ! ! between the patch "natural" leaf heat capacity and the minimum heat capacity for the ! - ! Runge-Kutta solver (checked at copy_patch_init). ! + ! Runge-Kutta solver (checked at copy_patch_init). ! !---------------------------------------------------------------------------------------! logical :: toosparse - + !---------------------------------------------------------------------------------------! + !----- Flag to tell whether there is at least one "resolvable" cohort in this patch ----! logical :: any_resolvable + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! Canopy air space capacities. These variables are used to convert the intensive ! + ! version of canopy air space prognostic variables (specific enthalpy, water vapour ! + ! specific humidity and CO2 mixing ratio) into extensive variables. ! + !---------------------------------------------------------------------------------------! + real(kind=8) :: wcapcan ! Water capacity [ kg_air/m²gnd] + real(kind=8) :: hcapcan ! Enthalpy capacity [ kg_air/m²gnd] + real(kind=8) :: ccapcan ! CO2 capacity [ mol_air/m²gnd] + real(kind=8) :: wcapcani ! Inverse of water capacity [ m²gnd/kg_air] + real(kind=8) :: hcapcani ! Inverse of enthalpy capacity [ m²gnd/kg_air] + real(kind=8) :: ccapcani ! Inverse of CO2 capacity [ m²gnd/mol_air] + !---------------------------------------------------------------------------------------! - !----- Canopy water and heat capacity variables. ---------------------------------------! - real(kind=8) :: zoveg - real(kind=8) :: zveg - real(kind=8) :: wcapcan - real(kind=8) :: wcapcani - real(kind=8) :: hcapcani - real(kind=8) :: ccapcani !=======================================================================================! !=======================================================================================! @@ -748,26 +761,36 @@ module rk4_coms ! Integrator error statistics. ! !---------------------------------------------------------------------------------------! !----- Number of variables other than soil and surface that will be analysed. ----------! - integer , parameter :: nerrfix = 20 + integer , parameter :: nerrfix = 21 + !---------------------------------------------------------------------------------------! + !----- Total number of variables that will be analysed. --------------------------------! integer :: nerr + !---------------------------------------------------------------------------------------! + !----- Default file name to be given to the error files. -------------------------------! character(len=str_len) :: errmax_fout character(len=str_len) :: sanity_fout character(len=str_len) :: thbnds_fout character(len=str_len) :: detail_pref + character(len=str_len) :: budget_pref + !---------------------------------------------------------------------------------------! + !----- The error counter and label. ----------------------------------------------------! integer(kind=8) , dimension(:,:), allocatable :: integ_err character(len=13), dimension(:) , allocatable :: integ_lab + !---------------------------------------------------------------------------------------! + !----- Offset needed for each of the following variables. ------------------------------! integer :: osow ! Soil water. integer :: osoe ! Soil energy. integer :: oswe ! Surface water energy. integer :: oswm ! Surface water mass. + !---------------------------------------------------------------------------------------! !=======================================================================================! !=======================================================================================! @@ -775,6 +798,48 @@ module rk4_coms contains + ! ========================================================== + ! The next three subroutines are for allocating + ! integration memory for the previous time-step's + ! leaf, wood and canopy temperature. This is needed + ! only in the BDF2 implicit solver method. + ! ========================================================= + + subroutine allocate_bdf2_patch(y,maxcohort) + + implicit none + type(bdf2patchtype), target :: y + integer :: maxcohort + + allocate(y%leaf_temp(maxcohort)) + allocate(y%wood_temp(maxcohort)) + + return + end subroutine allocate_bdf2_patch + + + subroutine deallocate_bdf2_patch(y) + + implicit none + type(bdf2patchtype),target :: y + + deallocate(y%leaf_temp) + deallocate(y%wood_temp) + return + end subroutine deallocate_bdf2_patch + + + subroutine nullify_bdf2_patch(y) + + implicit none + type(bdf2patchtype), target :: y + + nullify(y%leaf_temp) + nullify(y%wood_temp) + return + end subroutine nullify_bdf2_patch + + !=======================================================================================! !=======================================================================================! @@ -866,6 +931,19 @@ end subroutine nullify_rk4_patch + subroutine zero_bdf2_patch(y) + + implicit none + type(bdf2patchtype),target :: y + + y%can_temp = 0.d0 + y%leaf_temp = 0.d0 + y%wood_temp = 0.d0 + + return + end subroutine zero_bdf2_patch + + !=======================================================================================! !=======================================================================================! @@ -882,6 +960,7 @@ subroutine zero_rk4_patch(y) y%co2budget_storage = 0.d0 y%co2budget_loss2atm = 0.d0 y%ebudget_storage = 0.d0 + y%ebudget_netrad = 0.d0 y%ebudget_loss2atm = 0.d0 y%ebudget_loss2drainage = 0.d0 y%ebudget_loss2runoff = 0.d0 @@ -891,18 +970,17 @@ subroutine zero_rk4_patch(y) y%wbudget_loss2runoff = 0.d0 y%can_temp = 0.d0 - y%can_rvap = 0.d0 y%can_shv = 0.d0 y%can_ssh = 0.d0 y%can_rhv = 0.d0 y%can_co2 = 0.d0 y%can_theta = 0.d0 - y%can_theiv = 0.d0 - y%can_lntheta = 0.d0 + y%can_enthalpy = 0.d0 y%can_depth = 0.d0 y%can_rhos = 0.d0 y%can_prss = 0.d0 y%can_exner = 0.d0 + y%can_cp = 0.d0 y%veg_height = 0.d0 y%veg_displace = 0.d0 y%veg_rough = 0.d0 @@ -1003,6 +1081,9 @@ subroutine zero_rk4_patch(y) y%flx_sensible_ac = 0.d0 y%flx_heatstor_veg = 0.d0 + y%wflxgc = 0.d0 + y%wflxac = 0.d0 + y%flx_drainage = 0.d0 y%flx_drainage_heat = 0.d0 @@ -1129,7 +1210,6 @@ subroutine allocate_rk4_coh(maxcohort,y) allocate(y%veg_wind (maxcohort)) allocate(y%lai (maxcohort)) allocate(y%wai (maxcohort)) - allocate(y%wpa (maxcohort)) allocate(y%tai (maxcohort)) allocate(y%crown_area (maxcohort)) allocate(y%elongf (maxcohort)) @@ -1142,6 +1222,13 @@ subroutine allocate_rk4_coh(maxcohort,y) allocate(y%growth_resp (maxcohort)) allocate(y%storage_resp (maxcohort)) allocate(y%vleaf_resp (maxcohort)) + + allocate(y%wflxlc (maxcohort)) + allocate(y%wflxwc (maxcohort)) + allocate(y%wflxtr (maxcohort)) + allocate(y%hflx_wrsti (maxcohort)) + allocate(y%hflx_lrsti (maxcohort)) + allocate(y%cfx_hflxlc (maxcohort)) allocate(y%cfx_hflxwc (maxcohort)) allocate(y%cfx_qwflxlc (maxcohort)) @@ -1211,7 +1298,6 @@ subroutine nullify_rk4_cohort(y) nullify(y%veg_wind ) nullify(y%lai ) nullify(y%wai ) - nullify(y%wpa ) nullify(y%tai ) nullify(y%crown_area ) nullify(y%elongf ) @@ -1224,6 +1310,13 @@ subroutine nullify_rk4_cohort(y) nullify(y%growth_resp ) nullify(y%storage_resp ) nullify(y%vleaf_resp ) + + nullify(y%wflxlc ) + nullify(y%wflxwc ) + nullify(y%wflxtr ) + nullify(y%hflx_lrsti ) + nullify(y%hflx_wrsti ) + nullify(y%cfx_hflxlc ) nullify(y%cfx_hflxwc ) nullify(y%cfx_qwflxlc ) @@ -1291,7 +1384,6 @@ subroutine zero_rk4_cohort(y) if (associated(y%veg_wind )) y%veg_wind = 0.d0 if (associated(y%lai )) y%lai = 0.d0 if (associated(y%wai )) y%wai = 0.d0 - if (associated(y%wpa )) y%wpa = 0.d0 if (associated(y%tai )) y%tai = 0.d0 if (associated(y%crown_area )) y%crown_area = 0.d0 if (associated(y%elongf )) y%elongf = 0.d0 @@ -1304,6 +1396,13 @@ subroutine zero_rk4_cohort(y) if (associated(y%growth_resp )) y%growth_resp = 0.d0 if (associated(y%storage_resp )) y%storage_resp = 0.d0 if (associated(y%vleaf_resp )) y%vleaf_resp = 0.d0 + + if (associated(y%wflxlc )) y%wflxlc = 0.d0 + if (associated(y%wflxwc )) y%wflxwc = 0.d0 + if (associated(y%wflxtr )) y%wflxtr = 0.d0 + if (associated(y%hflx_wrsti )) y%hflx_wrsti = 0.d0 + if (associated(y%hflx_lrsti )) y%hflx_lrsti = 0.d0 + if (associated(y%cfx_hflxlc )) y%cfx_hflxlc = 0.d0 if (associated(y%cfx_hflxwc )) y%cfx_hflxwc = 0.d0 if (associated(y%cfx_qwflxlc )) y%cfx_qwflxlc = 0.d0 @@ -1371,7 +1470,6 @@ subroutine deallocate_rk4_coh(y) if (associated(y%veg_wind )) deallocate(y%veg_wind ) if (associated(y%lai )) deallocate(y%lai ) if (associated(y%wai )) deallocate(y%wai ) - if (associated(y%wpa )) deallocate(y%wpa ) if (associated(y%tai )) deallocate(y%tai ) if (associated(y%crown_area )) deallocate(y%crown_area ) if (associated(y%elongf )) deallocate(y%elongf ) @@ -1384,6 +1482,14 @@ subroutine deallocate_rk4_coh(y) if (associated(y%growth_resp )) deallocate(y%growth_resp ) if (associated(y%storage_resp )) deallocate(y%storage_resp ) if (associated(y%vleaf_resp )) deallocate(y%vleaf_resp ) + + if (associated(y%wflxlc )) deallocate(y%wflxlc ) + if (associated(y%wflxwc )) deallocate(y%wflxwc ) + if (associated(y%wflxtr )) deallocate(y%wflxtr ) + if (associated(y%hflx_lrsti )) deallocate(y%hflx_lrsti ) + if (associated(y%hflx_wrsti )) deallocate(y%hflx_wrsti ) + + if (associated(y%cfx_hflxlc )) deallocate(y%cfx_hflxlc ) if (associated(y%cfx_hflxwc )) deallocate(y%cfx_hflxwc ) if (associated(y%cfx_qwflxlc )) deallocate(y%cfx_qwflxlc ) @@ -1541,11 +1647,12 @@ end subroutine norm_rk4_fluxes !=======================================================================================! ! This subroutine will allocate the auxiliary variables. ! !---------------------------------------------------------------------------------------! - subroutine allocate_rk4_aux(mzg,mzs) + subroutine allocate_rk4_aux(mzg,mzs,mcoh) implicit none !----- Arguments --------------------------------------------------------------------! integer , intent(in) :: mzg integer , intent(in) :: mzs + integer , intent(in) :: mcoh !------------------------------------------------------------------------------------! @@ -1554,18 +1661,18 @@ subroutine allocate_rk4_aux(mzg,mzs) call nullify_rk4_aux() !------------------------------------------------------------------------------------! - allocate(rk4aux%psiplusz ( 0:mzg) ) - allocate(rk4aux%hydcond ( 0:mzg) ) - allocate(rk4aux%drysoil ( 0:mzg) ) - allocate(rk4aux%satsoil ( 0:mzg) ) - allocate(rk4aux%avail_h2o_lyr ( mzg+1) ) - allocate(rk4aux%avail_h2o_int ( mzg+1) ) - allocate(rk4aux%extracted_water ( mzg+1) ) - allocate(rk4aux%rfactor ( mzg+mzs) ) - allocate(rk4aux%hfluxgsc (mzg+mzs+1) ) - allocate(rk4aux%w_flux (mzg+mzs+1) ) - allocate(rk4aux%qw_flux (mzg+mzs+1) ) - allocate(rk4aux%d_flux ( mzs+1) ) + allocate(rk4aux%psiplusz ( 0:mzg) ) + allocate(rk4aux%hydcond ( 0:mzg) ) + allocate(rk4aux%drysoil ( 0:mzg) ) + allocate(rk4aux%satsoil ( 0:mzg) ) + allocate(rk4aux%avail_h2o_lyr ( mzg+1) ) + allocate(rk4aux%avail_h2o_int ( mzg+1) ) + allocate(rk4aux%rfactor ( mzg+mzs) ) + allocate(rk4aux%hfluxgsc ( mzg+mzs+1) ) + allocate(rk4aux%w_flux ( mzg+mzs+1) ) + allocate(rk4aux%qw_flux ( mzg+mzs+1) ) + allocate(rk4aux%d_flux ( mzs+1) ) + allocate(rk4aux%extracted_water (mcoh, mzg+1) ) !------ Flush the variables within this structure to zero. --------------------------! @@ -1619,18 +1726,18 @@ end subroutine nullify_rk4_aux subroutine zero_rk4_aux() implicit none - if (associated(rk4aux%psiplusz )) rk4aux%psiplusz (:) = 0.d0 - if (associated(rk4aux%hydcond )) rk4aux%hydcond (:) = 0.d0 - if (associated(rk4aux%drysoil )) rk4aux%drysoil (:) = .false. - if (associated(rk4aux%satsoil )) rk4aux%satsoil (:) = .false. - if (associated(rk4aux%avail_h2o_lyr )) rk4aux%avail_h2o_lyr (:) = 0.d0 - if (associated(rk4aux%avail_h2o_int )) rk4aux%avail_h2o_int (:) = 0.d0 - if (associated(rk4aux%extracted_water )) rk4aux%extracted_water (:) = 0.d0 - if (associated(rk4aux%rfactor )) rk4aux%rfactor (:) = 0.d0 - if (associated(rk4aux%hfluxgsc )) rk4aux%hfluxgsc (:) = 0.d0 - if (associated(rk4aux%w_flux )) rk4aux%w_flux (:) = 0.d0 - if (associated(rk4aux%qw_flux )) rk4aux%qw_flux (:) = 0.d0 - if (associated(rk4aux%d_flux )) rk4aux%d_flux (:) = 0.d0 + if (associated(rk4aux%psiplusz )) rk4aux%psiplusz (: ) = 0.d0 + if (associated(rk4aux%hydcond )) rk4aux%hydcond (: ) = 0.d0 + if (associated(rk4aux%drysoil )) rk4aux%drysoil (: ) = .false. + if (associated(rk4aux%satsoil )) rk4aux%satsoil (: ) = .false. + if (associated(rk4aux%avail_h2o_lyr )) rk4aux%avail_h2o_lyr (: ) = 0.d0 + if (associated(rk4aux%avail_h2o_int )) rk4aux%avail_h2o_int (: ) = 0.d0 + if (associated(rk4aux%rfactor )) rk4aux%rfactor (: ) = 0.d0 + if (associated(rk4aux%hfluxgsc )) rk4aux%hfluxgsc (: ) = 0.d0 + if (associated(rk4aux%w_flux )) rk4aux%w_flux (: ) = 0.d0 + if (associated(rk4aux%qw_flux )) rk4aux%qw_flux (: ) = 0.d0 + if (associated(rk4aux%d_flux )) rk4aux%d_flux (: ) = 0.d0 + if (associated(rk4aux%extracted_water )) rk4aux%extracted_water (:,:) = 0.d0 return end subroutine zero_rk4_aux @@ -1655,12 +1762,12 @@ subroutine deallocate_rk4_aux() if (associated(rk4aux%satsoil )) deallocate(rk4aux%satsoil ) if (associated(rk4aux%avail_h2o_lyr )) deallocate(rk4aux%avail_h2o_lyr ) if (associated(rk4aux%avail_h2o_int )) deallocate(rk4aux%avail_h2o_int ) - if (associated(rk4aux%extracted_water )) deallocate(rk4aux%extracted_water ) if (associated(rk4aux%rfactor )) deallocate(rk4aux%rfactor ) if (associated(rk4aux%hfluxgsc )) deallocate(rk4aux%hfluxgsc ) if (associated(rk4aux%w_flux )) deallocate(rk4aux%w_flux ) if (associated(rk4aux%qw_flux )) deallocate(rk4aux%qw_flux ) if (associated(rk4aux%d_flux )) deallocate(rk4aux%d_flux ) + if (associated(rk4aux%extracted_water )) deallocate(rk4aux%extracted_water ) return end subroutine deallocate_rk4_aux @@ -1732,10 +1839,11 @@ subroutine assign_err_label() implicit none !----- Local constants. -------------------------------------------------------------! character(len=13), dimension(nerrfix), parameter :: err_lab_fix = (/ & - 'CAN_THEIV ','CAN_THETA ','CAN_SHV ','CAN_TEMP ','CAN_PRSS ' & + 'CAN_ENTHALPY ','CAN_THETA ','CAN_SHV ','CAN_TEMP ','CAN_PRSS ' & ,'CAN_CO2 ','LEAF_WATER ','LEAF_ENERGY ','WOOD_WATER ','WOOD_ENERGY ' & - ,'VIRT_HEAT ','VIRT_WATER ','CO2B_STORAGE ','CO2B_LOSS2ATM','EB_LOSS2ATM ' & - ,'WATB_LOSS2ATM','ENB_LOSS2DRA ','WATB_LOSS2DRA','ENB_STORAGE ','WATB_STORAGE '/) + ,'VIRT_HEAT ','VIRT_WATER ','CO2B_STORAGE ','CO2B_LOSS2ATM','EB_NETRAD ' & + ,'EB_LOSS2ATM ','WATB_LOSS2ATM','ENB_LOSS2DRA ','WATB_LOSS2DRA','ENB_STORAGE ' & + ,'WATB_STORAGE '/) !----- Local variables. -------------------------------------------------------------! integer :: n character(len=13) :: err_lab_loc @@ -1782,25 +1890,21 @@ end subroutine assign_err_label !=======================================================================================! !=======================================================================================! - subroutine find_derived_thbounds(can_rhos,can_theta,can_temp,can_shv,can_rvap,can_prss & - ,can_depth) + subroutine find_derived_thbounds(can_rhos,can_theta,can_temp,can_shv,can_prss,can_depth) use grid_coms , only : nzg ! ! intent(in) - use consts_coms , only : p008 & ! intent(in) - , rocp8 & ! intent(in) - , cp8 & ! intent(in) - , rdry8 & ! intent(in) + use consts_coms , only : rdry8 & ! intent(in) , epim18 & ! intent(in) , ep8 & ! intent(in) , mmdryi8 & ! intent(in) - , day_sec & ! intent(in) , hr_sec & ! intent(in) , min_sec ! ! intent(in) - use therm_lib8 , only : thetaeiv8 & ! function + use therm_lib8 , only : press2exner8 & ! function + , extemp2theta8 & ! function + , tq2enthalpy8 & ! function + , thetaeiv8 & ! function , thetaeivs8 & ! function , idealdenssh8 & ! function - , reducedpress8 & ! function - , eslif8 & ! function - , rslif8 ! ! function + , reducedpress8 ! ! function use soil_coms , only : soil8 ! ! intent(in) use ed_misc_coms, only : current_time ! ! intent(in) implicit none @@ -1809,13 +1913,13 @@ subroutine find_derived_thbounds(can_rhos,can_theta,can_temp,can_shv,can_rvap,ca real(kind=8) , intent(in) :: can_theta real(kind=8) , intent(in) :: can_temp real(kind=8) , intent(in) :: can_shv - real(kind=8) , intent(in) :: can_rvap real(kind=8) , intent(in) :: can_prss real(kind=8) , intent(in) :: can_depth !----- Local variables. -------------------------------------------------------------! real(kind=8) :: can_prss_try + real(kind=8) :: can_exner_try real(kind=8) :: can_theta_try - real(kind=8) :: can_theiv_try + real(kind=8) :: can_enthalpy_try integer :: k integer :: hour integer :: minute @@ -1842,8 +1946,8 @@ subroutine find_derived_thbounds(can_rhos,can_theta,can_temp,can_shv,can_rvap,ca ,' HOUR',' MINU',' SECO' & ,' MIN_TEMP',' MAX_TEMP',' MIN_SHV' & ,' MAX_SHV',' MIN_THETA',' MAX_THETA' & - ,' MIN_THEIV',' MAX_THEIV',' MIN_PRSS' & - ,' MAX_PRSS' + ,' MIN_PRSS',' MAX_PRSS','MIN_ENTHALPY' & + ,'MAX_ENTHALPY' close(unit=39,status='keep') end if firsttime = .false. @@ -1859,25 +1963,9 @@ subroutine find_derived_thbounds(can_rhos,can_theta,can_temp,can_shv,can_rvap,ca !------------------------------------------------------------------------------------! !----- 1. Initial value, the most extreme one. --------------------------------------! rk4min_can_prss = reducedpress8(rk4site%atm_prss,rk4site%atm_theta,rk4site%atm_shv & - ,5.d-1*rk4site%geoht,can_theta,can_shv,can_depth) + ,9.d-1*rk4site%geoht,can_theta,can_shv,can_depth) rk4max_can_prss = reducedpress8(rk4site%atm_prss,rk4site%atm_theta,rk4site%atm_shv & ,1.1d0*rk4site%geoht,can_theta,can_shv,can_depth) - !----- 2. Minimum temperature. ------------------------------------------------------! - can_prss_try = can_rhos * rdry8 * rk4min_can_temp * (1.d0 + epim18 * can_shv) - rk4min_can_prss = min(rk4min_can_prss,can_prss_try) - rk4max_can_prss = max(rk4max_can_prss,can_prss_try) - !----- 3. Maximum temperature. ------------------------------------------------------! - can_prss_try = can_rhos * rdry8 * rk4max_can_temp * (1.d0 + epim18 * can_shv) - rk4min_can_prss = min(rk4min_can_prss,can_prss_try) - rk4max_can_prss = max(rk4max_can_prss,can_prss_try) - !----- 4. Minimum specific humidity. ------------------------------------------------! - can_prss_try = can_rhos * rdry8 * can_temp * (1.d0 + epim18 * rk4min_can_shv) - rk4min_can_prss = min(rk4min_can_prss,can_prss_try) - rk4max_can_prss = max(rk4max_can_prss,can_prss_try) - !----- 5. Maximum specific humidity. ------------------------------------------------! - can_prss_try = can_rhos * rdry8 * can_temp * (1.d0 + epim18 * rk4max_can_shv) - rk4min_can_prss = min(rk4min_can_prss,can_prss_try) - rk4max_can_prss = max(rk4max_can_prss,can_prss_try) !------------------------------------------------------------------------------------! @@ -1891,46 +1979,51 @@ subroutine find_derived_thbounds(can_rhos,can_theta,can_temp,can_shv,can_rvap,ca rk4min_can_theta = huge(1.d0) rk4max_can_theta = -huge(1.d0) !----- 2. Minimum temperature. ------------------------------------------------------! - can_theta_try = rk4min_can_temp * (p008 / can_prss) ** rocp8 + can_exner_try = press2exner8(can_prss) + can_theta_try = extemp2theta8(can_exner_try,rk4min_can_temp) rk4min_can_theta = min(rk4min_can_theta,can_theta_try) rk4max_can_theta = max(rk4max_can_theta,can_theta_try) !----- 3. Maximum temperature. ------------------------------------------------------! - can_theta_try = rk4max_can_temp * (p008 / can_prss) ** rocp8 + can_exner_try = press2exner8(can_prss) + can_theta_try = extemp2theta8(can_exner_try,rk4max_can_temp) rk4min_can_theta = min(rk4min_can_theta,can_theta_try) rk4max_can_theta = max(rk4max_can_theta,can_theta_try) !----- 4. Minimum pressure. ---------------------------------------------------------! - can_theta_try = can_temp * (p008 / rk4min_can_prss) ** rocp8 + can_exner_try = press2exner8(rk4min_can_prss) + can_theta_try = extemp2theta8(can_exner_try,can_temp) rk4min_can_theta = min(rk4min_can_theta,can_theta_try) rk4max_can_theta = max(rk4max_can_theta,can_theta_try) !----- 5. Maximum pressure. ---------------------------------------------------------! - can_theta_try = can_temp * (p008 / rk4max_can_prss) ** rocp8 + can_exner_try = press2exner8(rk4max_can_prss) + can_theta_try = extemp2theta8(can_exner_try,can_temp) rk4min_can_theta = min(rk4min_can_theta,can_theta_try) rk4max_can_theta = max(rk4max_can_theta,can_theta_try) - !----- 6. Find the logarithms. ------------------------------------------------------! - rk4min_can_lntheta = log(rk4min_can_theta) - rk4max_can_lntheta = log(rk4max_can_theta) !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! - ! Minimum and maximum ice-vapour equivalent potential temperature. ! + ! Minimum and maximum enthalpy. ! !------------------------------------------------------------------------------------! !----- 1. Initial value, the most extreme one. --------------------------------------! - rk4min_can_theiv = rk4min_can_theta - rk4max_can_theiv = -huge(1.d0) - !----- 2. Maximum temperature. ------------------------------------------------------! - can_theta_try = rk4max_can_temp * (p008 / can_prss) ** rocp8 - can_theiv_try = thetaeivs8(can_theta_try,rk4max_can_temp,can_rvap,0.d0,0.d0) - rk4max_can_theiv = max(rk4max_can_theiv,can_theiv_try) - !----- 3. Minimum pressure. ---------------------------------------------------------! - can_theta_try = can_temp * (p008 / rk4min_can_prss) ** rocp8 - can_theiv_try = thetaeivs8(can_theta_try,can_temp,can_rvap,0.d0,0.d0) - rk4max_can_theiv = max(rk4max_can_theiv,can_theiv_try) - !----- 4. Maximum vapour mixing ratio. ----------------------------------------------! - can_theta_try = can_temp * (p008 / can_prss) ** rocp8 - can_theiv_try = thetaeivs8(can_theta_try,can_temp,rk4max_can_rvap,0.d0,0.d0) - rk4max_can_theiv = max(rk4max_can_theiv,can_theiv_try) + rk4min_can_enthalpy = huge(1.d0) + rk4max_can_enthalpy = - huge(1.d0) + !----- 2. Minimum temperature. ------------------------------------------------------! + can_enthalpy_try = tq2enthalpy8(rk4min_can_temp,can_shv,.true.) + rk4min_can_enthalpy = min(rk4min_can_enthalpy,can_enthalpy_try) + rk4max_can_enthalpy = max(rk4max_can_enthalpy,can_enthalpy_try) + !----- 3. Maximum temperature. ------------------------------------------------------! + can_enthalpy_try = tq2enthalpy8(rk4max_can_temp,can_shv,.true.) + rk4min_can_enthalpy = min(rk4min_can_enthalpy,can_enthalpy_try) + rk4max_can_enthalpy = max(rk4max_can_enthalpy,can_enthalpy_try) + !----- 4. Minimum specific humidity. ------------------------------------------------! + can_enthalpy_try = tq2enthalpy8(can_temp,rk4min_can_shv,.true.) + rk4min_can_enthalpy = min(rk4min_can_enthalpy,can_enthalpy_try) + rk4max_can_enthalpy = max(rk4max_can_enthalpy,can_enthalpy_try) + !----- 5. Maximum specific humidity. ------------------------------------------------! + can_enthalpy_try = tq2enthalpy8(can_temp,rk4max_can_shv,.true.) + rk4min_can_enthalpy = min(rk4min_can_enthalpy,can_enthalpy_try) + rk4max_can_enthalpy = max(rk4max_can_enthalpy,can_enthalpy_try) !------------------------------------------------------------------------------------! if (print_thbnd) then @@ -1944,9 +2037,9 @@ subroutine find_derived_thbounds(can_rhos,can_theta,can_temp,can_shv,can_rvap,ca current_time%year, current_time%month, current_time%date & , hour, minute, second & , rk4min_can_temp, rk4max_can_temp, rk4min_can_shv & - , rk4min_can_shv, rk4min_can_theta, rk4max_can_theta & - , rk4min_can_theiv, rk4max_can_theiv, rk4min_can_prss & - , rk4max_can_prss + , rk4max_can_shv, rk4min_can_theta, rk4max_can_theta & + , rk4min_can_prss, rk4max_can_prss,rk4min_can_enthalpy & + ,rk4max_can_enthalpy close (unit=39,status='keep') end if diff --git a/ED/src/memory/soil_coms.F90 b/ED/src/memory/soil_coms.F90 index ef7fa3f05..8c33c9ec2 100644 --- a/ED/src/memory/soil_coms.F90 +++ b/ED/src/memory/soil_coms.F90 @@ -161,6 +161,7 @@ module soil_coms real(kind=4) :: slpotwp ! Water potential for wilting point [ m] real(kind=4) :: slpotfc ! Water potential for field capacity [ m] real(kind=4) :: slpotld ! Water pot. below which drought phen happens [ m] + real(kind=4) :: slpotfr ! Water pot. below which fire happens [ m] end type soil_class !----- Double precision version --------------------------------------------------------! type soil_class8 @@ -188,6 +189,7 @@ module soil_coms real(kind=8) :: slpotwp ! Water potential for wilting point [ m] real(kind=8) :: slpotfc ! Water potential for field capacity [ m] real(kind=8) :: slpotld ! Water pot. below which drought phen happens [ m] + real(kind=8) :: slpotfr ! Water pot. below which fire happens [ m] end type soil_class8 !---------------------------------------------------------------------------------------! !----- To be filled in ed_params.f90. --------------------------------------------------! diff --git a/ED/src/mpi/ed_mpass_init.f90 b/ED/src/mpi/ed_mpass_init.f90 index 824c7af38..281c48bf0 100644 --- a/ED/src/mpi/ed_mpass_init.f90 +++ b/ED/src/mpi/ed_mpass_init.f90 @@ -248,13 +248,15 @@ subroutine ed_masterput_nl(par_run) , plantation_stock & ! intent(in) , pft_1st_check ! ! intent(in) use disturb_coms , only : include_fire & ! intent(in) + , fire_parameter & ! intent(in) , ianth_disturb & ! intent(in) , treefall_disturbance_rate & ! intent(in) , lu_database & ! intent(in) , plantation_file & ! intent(in) , lu_rescale_file & ! intent(in) , sm_fire & ! intent(in) - , time2canopy ! ! intent(in) + , time2canopy & ! intent(in) + , min_patch_area ! ! intent(in) use optimiz_coms , only : ioptinpt ! ! intent(in) use canopy_layer_coms , only : crown_mod ! ! intent(in) use canopy_radiation_coms, only : icanrad & ! intent(in) @@ -269,7 +271,8 @@ subroutine ed_masterput_nl(par_run) use rk4_coms , only : rk4_tolerance & ! intent(in) , ibranch_thermo & ! intent(in) , ipercol ! ! intent(in) - + use detailed_coms , only : idetailed & ! intent(in) + , patch_keep ! ! intent(in) implicit none include 'mpif.h' integer :: ierr @@ -444,6 +447,7 @@ subroutine ed_masterput_nl(par_run) call MPI_Bcast(n_plant_lim,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(n_decomp_lim,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(include_fire,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) + call MPI_Bcast(fire_parameter,1,MPI_REAL,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(sm_fire,1,MPI_REAL,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(ianth_disturb,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(include_these_pft,n_pft,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) @@ -497,6 +501,7 @@ subroutine ed_masterput_nl(par_run) call MPI_Bcast(maxpatch,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(maxcohort,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(min_site_area,1,MPI_REAL,mainnum,MPI_COMM_WORLD,ierr) + call MPI_Bcast(min_patch_area,1,MPI_REAL,mainnum,MPI_COMM_WORLD,ierr) call MPI_Bcast(ioptinpt,str_len,MPI_CHARACTER,mainnum,MPI_COMM_WORLD,ierr) @@ -506,6 +511,10 @@ subroutine ed_masterput_nl(par_run) call MPI_Bcast(attach_metadata,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) + + call MPI_Bcast(idetailed,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) + call MPI_Bcast(patch_keep,1,MPI_INTEGER,mainnum,MPI_COMM_WORLD,ierr) + !---------------------------------------------------------------------------------------! ! One last thing to send is the layer index based on the soil_depth. It is not really ! ! a namelist thing, but it is still a setup variable. ! @@ -1328,13 +1337,15 @@ subroutine ed_nodeget_nl , plantation_stock & ! intent(out) , pft_1st_check ! ! intent(out) use disturb_coms , only : include_fire & ! intent(out) + , fire_parameter & ! intent(out) , ianth_disturb & ! intent(out) , treefall_disturbance_rate & ! intent(out) , lu_database & ! intent(out) , plantation_file & ! intent(out) , lu_rescale_file & ! intent(out) , sm_fire & ! intent(out) - , time2canopy ! ! intent(out) + , time2canopy & ! intent(out) + , min_patch_area ! ! intent(out) use optimiz_coms , only : ioptinpt ! ! intent(out) use canopy_layer_coms , only : crown_mod ! ! intent(out) use canopy_radiation_coms, only : icanrad & ! intent(out) @@ -1349,7 +1360,8 @@ subroutine ed_nodeget_nl use rk4_coms , only : rk4_tolerance & ! intent(out) , ibranch_thermo & ! intent(out) , ipercol ! ! intent(out) - + use detailed_coms , only : idetailed & ! intent(out) + , patch_keep ! ! intent(out) implicit none include 'mpif.h' integer :: ierr @@ -1530,6 +1542,7 @@ subroutine ed_nodeget_nl call MPI_Bcast(n_plant_lim,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(n_decomp_lim,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(include_fire,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) + call MPI_Bcast(fire_parameter,1,MPI_REAL,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(sm_fire,1,MPI_REAL,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(ianth_disturb,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(include_these_pft,n_pft,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) @@ -1583,6 +1596,7 @@ subroutine ed_nodeget_nl call MPI_Bcast(maxpatch,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(maxcohort,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(min_site_area,1,MPI_REAL,master_num,MPI_COMM_WORLD,ierr) + call MPI_Bcast(min_patch_area,1,MPI_REAL,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(ioptinpt,str_len,MPI_CHARACTER,master_num,MPI_COMM_WORLD,ierr) @@ -1591,6 +1605,9 @@ subroutine ed_nodeget_nl call MPI_Bcast(edres,1,MPI_REAL,master_num,MPI_COMM_WORLD,ierr) call MPI_Bcast(attach_metadata,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) + + call MPI_Bcast(idetailed,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) + call MPI_Bcast(patch_keep,1,MPI_INTEGER,master_num,MPI_COMM_WORLD,ierr) !------------------------------------------------------------------------------------------! ! Receiving the layer index based on soil_depth. This is allocatable, so I first ! diff --git a/ED/src/utils/allometry.f90 b/ED/src/utils/allometry.f90 index 436c93dd9..83ddda391 100644 --- a/ED/src/utils/allometry.f90 +++ b/ED/src/utils/allometry.f90 @@ -308,7 +308,7 @@ integer function dbh2krdepth(hgt,dbh,ipft,lsl) volume = dbh2vol(hgt,dbh,ipft) root_depth = b1Rd(ipft) * volume ** b2Rd(ipft) - case (2) + case (1,2) !---------------------------------------------------------------------------------! ! This is just a test allometry, that imposes root depth to be 0.5 m for ! ! plants that are 0.15-m tall, and 5.0 m for plants that are 35-m tall. ! @@ -443,8 +443,8 @@ end function ed_biomass ! climate change conditions. The Open Geography Journal, 3, 91-102 (they ! ! didn't develop the allometry, but the original reference is in German...) ! !---------------------------------------------------------------------------------------! - subroutine area_indices(nplant,bleaf,bdead,balive,dbh,hite,pft,sla,lai,wpa,wai & - ,crown_area,bsapwood) + subroutine area_indices(nplant,bleaf,bdead,balive,dbh,hite,pft,sla,lai,wai,crown_area & + ,bsapwood) use pft_coms , only : is_tropical & ! intent(in) , rho & ! intent(in) , C2B & ! intent(in) @@ -466,7 +466,6 @@ subroutine area_indices(nplant,bleaf,bdead,balive,dbh,hite,pft,sla,lai,wpa,wai real , intent(in) :: hite ! Plant height [ m] real , intent(in) :: sla ! Specific leaf area [m²leaf/plant] real , intent(out) :: lai ! Leaf area index [ m²leaf/m²] - real , intent(out) :: wpa ! Wood projected area [ m²wood/m²] real , intent(out) :: wai ! Wood area index [ m²wood/m²] real , intent(out) :: crown_area ! Crown area [ m²crown/m²] !----- Local variables --------------------------------------------------------------! @@ -495,7 +494,6 @@ subroutine area_indices(nplant,bleaf,bdead,balive,dbh,hite,pft,sla,lai,wpa,wai select case (ibranch_thermo) case (0) !----- Ignore branches and trunk. ------------------------------------------------! - wpa = 0. wai = 0. !---------------------------------------------------------------------------------! @@ -504,7 +502,6 @@ subroutine area_indices(nplant,bleaf,bdead,balive,dbh,hite,pft,sla,lai,wpa,wai ! Solve branches using the equations from Ahrends et al. (2010). ! !---------------------------------------------------------------------------------! wai = nplant * b1WAI(pft) * min(dbh,dbh_crit(pft)) ** b2WAI(pft) - wpa = wai * dbh2ca(dbh,sla,pft) !---------------------------------------------------------------------------------! end select diff --git a/ED/src/utils/budget_utils.f90 b/ED/src/utils/budget_utils.f90 index d74095313..5ce01a77c 100644 --- a/ED/src/utils/budget_utils.f90 +++ b/ED/src/utils/budget_utils.f90 @@ -42,12 +42,13 @@ end subroutine update_budget !==========================================================================================! !==========================================================================================! -subroutine compute_budget(csite,lsl,pcpg,qpcpg,ipa,wcurr_loss2atm,ecurr_loss2atm & - ,co2curr_loss2atm,wcurr_loss2drainage,ecurr_loss2drainage & - ,wcurr_loss2runoff,ecurr_loss2runoff,site_area & - ,cbudget_nep,old_can_theiv,old_can_shv,old_can_co2,old_can_rhos & - ,old_can_temp) +subroutine compute_budget(csite,lsl,pcpg,qpcpg,ipa,wcurr_loss2atm,ecurr_netrad & + ,ecurr_loss2atm,co2curr_loss2atm,wcurr_loss2drainage & + ,ecurr_loss2drainage,wcurr_loss2runoff,ecurr_loss2runoff & + ,site_area,cbudget_nep,old_can_enthalpy,old_can_shv,old_can_co2 & + ,old_can_rhos,old_can_temp,old_can_prss) use ed_state_vars, only : sitetype ! ! structure + use ed_max_dims , only : str_len ! ! intent(in) use ed_misc_coms , only : dtlsm & ! intent(in) , fast_diagnostics & ! intent(in) , current_time ! ! intent(in) @@ -55,112 +56,183 @@ subroutine compute_budget(csite,lsl,pcpg,qpcpg,ipa,wcurr_loss2atm,ecurr_loss2atm use consts_coms , only : umol_2_kgC & ! intent(in) , day_sec & ! intent(in) , rdry & ! intent(in) - , cp & ! intent(in) , mmdryi & ! intent(in) , epim1 ! ! intent(in) use rk4_coms , only : rk4eps & ! intent(in) + , print_budget & ! intent(in) + , budget_pref & ! intent(in) , checkbudget ! ! intent(in) + use therm_lib , only : tq2enthalpy ! ! function implicit none !----- Arguments -----------------------------------------------------------------------! - type(sitetype) , target :: csite - real , intent(in) :: pcpg - real , intent(in) :: qpcpg - real , intent(in) :: co2curr_loss2atm - real , intent(in) :: ecurr_loss2atm - real , intent(in) :: ecurr_loss2drainage - real , intent(in) :: ecurr_loss2runoff - real , intent(in) :: wcurr_loss2atm - real , intent(in) :: wcurr_loss2drainage - real , intent(in) :: wcurr_loss2runoff - integer , intent(in) :: lsl - integer , intent(in) :: ipa - real , intent(in) :: site_area - real , intent(inout) :: cbudget_nep - real , intent(in) :: old_can_theiv - real , intent(in) :: old_can_shv - real , intent(in) :: old_can_co2 - real , intent(in) :: old_can_rhos - real , intent(in) :: old_can_temp + type(sitetype) , target :: csite + real , intent(inout) :: pcpg + real , intent(inout) :: qpcpg + real , intent(inout) :: co2curr_loss2atm + real , intent(inout) :: ecurr_netrad + real , intent(inout) :: ecurr_loss2atm + real , intent(inout) :: ecurr_loss2drainage + real , intent(inout) :: ecurr_loss2runoff + real , intent(inout) :: wcurr_loss2atm + real , intent(inout) :: wcurr_loss2drainage + real , intent(inout) :: wcurr_loss2runoff + integer , intent(in) :: lsl + integer , intent(in) :: ipa + real , intent(in) :: site_area + real , intent(inout) :: cbudget_nep + real , intent(in) :: old_can_enthalpy + real , intent(in) :: old_can_shv + real , intent(in) :: old_can_co2 + real , intent(in) :: old_can_rhos + real , intent(in) :: old_can_temp + real , intent(in) :: old_can_prss !----- Local variables -----------------------------------------------------------------! - real, dimension(n_dbh) :: gpp_dbh - real :: co2budget_finalstorage - real :: co2budget_deltastorage - real :: co2curr_gpp - real :: co2curr_leafresp - real :: co2curr_rootresp - real :: co2curr_growthresp - real :: co2curr_storageresp - real :: co2curr_vleafresp - real :: co2curr_hetresp - real :: co2curr_nep - real :: co2curr_denseffect - real :: co2curr_residual - real :: ebudget_finalstorage - real :: ebudget_deltastorage - real :: ecurr_precipgain - real :: ecurr_netrad - real :: ecurr_denseffect - real :: ecurr_residual - real :: wbudget_finalstorage - real :: wbudget_deltastorage - real :: wcurr_precipgain - real :: wcurr_denseffect - real :: wcurr_residual - real :: gpp - real :: leaf_resp - real :: root_resp - real :: growth_resp - real :: storage_resp - real :: vleaf_resp - real :: old_can_rhotemp - real :: curr_can_rhotemp - real :: old_can_lntheiv - real :: curr_can_lntheiv - logical :: co2_ok - logical :: energy_ok - logical :: water_ok + character(len=str_len) :: budget_fout + real, dimension(n_dbh) :: gpp_dbh + real :: co2budget_finalstorage + real :: co2budget_deltastorage + real :: co2curr_gpp + real :: co2curr_leafresp + real :: co2curr_rootresp + real :: co2curr_growthresp + real :: co2curr_storageresp + real :: co2curr_vleafresp + real :: co2curr_hetresp + real :: co2curr_nep + real :: co2curr_denseffect + real :: co2curr_residual + real :: ebudget_finalstorage + real :: ebudget_deltastorage + real :: ecurr_precipgain + real :: ecurr_denseffect + real :: ecurr_prsseffect + real :: ecurr_residual + real :: wbudget_finalstorage + real :: wbudget_deltastorage + real :: wcurr_precipgain + real :: wcurr_denseffect + real :: wcurr_residual + real :: curr_can_enthalpy + real :: gpp + real :: leaf_resp + real :: root_resp + real :: growth_resp + real :: storage_resp + real :: vleaf_resp + real :: co2_factor + real :: ene_factor + real :: h2o_factor + integer :: jpa + logical :: isthere + logical :: co2_ok + logical :: energy_ok + logical :: water_ok !----- Local constants. ----------------------------------------------------------------! character(len=13) , parameter :: fmtf='(a,1x,es14.7)' - logical , parameter :: print_debug = .false. + character(len=10) , parameter :: bhfmt='(31(a,1x))' + character(len=48) , parameter :: bbfmt='(3(i13,1x),28(es13.6,1x))' !----- External functions. -------------------------------------------------------------! real , external :: compute_netrad real , external :: compute_water_storage real , external :: compute_energy_storage real , external :: compute_co2_storage real , external :: ddens_dt_effect + !----- Locally saved variables. --------------------------------------------------------! + logical , save :: first_time = .true. !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! If this is the first time, we initialise all files with their headers. ! + !---------------------------------------------------------------------------------------! + if (first_time) then + do jpa = 1, csite%npatches + write(budget_fout,fmt='(2a,i4.4,a)') trim(budget_pref),'patch_',jpa,'.txt' + inquire(file=trim(budget_fout),exist=isthere) + if (isthere) then + !---- Open the file to delete when closing. -----------------------------------! + open (unit=86,file=trim(budget_fout),status='old',action='write') + close(unit=86,status='delete') + end if + !---------------------------------------------------------------------------------! + + if (print_budget) then + !------------------------------------------------------------------------------! + open (unit=86,file=trim(budget_fout),status='replace',action='write') + write(unit=86,fmt=bhfmt) ' YEAR' , ' MONTH' , ' DAY' & + , ' TIME' , ' LAI' , ' WAI' & + , ' HEIGHT' , ' CO2.STORAGE' , ' CO2.RESIDUAL' & + , ' CO2.DSTORAGE' , ' CO2.NEP' , ' CO2.DENS.EFF' & + , ' CO2.LOSS2ATM' , ' ENE.STORAGE' , ' ENE.RESIDUAL' & + , ' ENE.DSTORAGE' , ' ENE.PRECIP' , ' ENE.NETRAD' & + , ' ENE.DENS.EFF' , ' ENE.PRSS.EFF' , ' ENE.LOSS2ATM' & + , ' ENE.DRAINAGE' , ' ENE.RUNOFF' , ' H2O.STORAGE' & + , ' H2O.RESIDUAL' , ' H2O.DSTORAGE' , ' H2O.PRECIP' & + , ' H2O.DENS.EFF' , ' H2O.LOSS2ATM' , ' H2O.DRAINAGE' & + , ' H2O.RUNOFF' + + close(unit=86,status='keep') + end if + end do + first_time = .false. + end if + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! ! Compute gain in water and energy due to precipitation. ! !---------------------------------------------------------------------------------------! wcurr_precipgain = pcpg * dtlsm ecurr_precipgain = qpcpg * dtlsm - - !---------------------------------------------------------------------------------------! - ! Compute gain in energy due to radiation. ! !---------------------------------------------------------------------------------------! - ecurr_netrad = compute_netrad(csite,ipa) * dtlsm + !---------------------------------------------------------------------------------------! - ! Compute the effect that change density had in the total canopy storage. ! - !---------------------------------------------------------------------------------------! + ! Compute the density and pressure effects. We seek the conservation of the ! + ! extensive properties [X/m2], but the canopy air space solves the intensive quantities ! + ! instead [X/mol or X/kg]. Because density is not constant within the time step, and ! + ! during the integration we solve the intensive form for the canopy air space, we must ! + ! subtract the density effect from the residual. The derivation is shown below. The ! + ! storage term is what we aim at, but in reality we solve the equations after the >>>. ! + ! ! + ! dM d(rho*z*m) dm d(rho) ! + ! ---- = I - L -> ------------ = I - L >>> rho * z * ---- = I - L - m * z * -------- ! + ! dt dt dt dt ! + ! ! + ! where M is the extensive propery, I is the input flux, L is the loss flux, z is the ! + ! canopy air space depth, and rho is the canopy air space density. ! + ! For the specific case of enthalpy, we also compute the pressure effect between ! + ! time steps. We cannot guarantee conservation of enthalpy when we update pressure, ! + ! because of the first law of thermodynamics (the way to address this would be to use ! + ! equivalent potential temperature, which is enthalpy plus pressure effect). Enthalpy ! + ! is preserved within one time step, once pressure is updated and remains constant. ! + ! ! + ! dH dp dh dp d(rho) ! + ! ---- - V * ---- = Q >>> rho * z * ---- = Q + z * ---- - m * z * -------- ! + ! dt dt dt dt dt ! + ! ! + ! where p is the canopy air space pressure, Q is the net heat exchange, V is the volume ! + ! of the canopy air space. ! + !---------------------------------------------------------------------------------------! + !------ CO2. Density effect only. -----------------------------------------------------! co2curr_denseffect = ddens_dt_effect(old_can_rhos,csite%can_rhos(ipa) & ,old_can_co2,csite%can_co2(ipa) & ,csite%can_depth(ipa),mmdryi) + !------ Water. Density effect only. ----------------------------------------------------! wcurr_denseffect = ddens_dt_effect(old_can_rhos,csite%can_rhos(ipa) & ,old_can_shv,csite%can_shv(ipa) & ,csite%can_depth(ipa),1.) - - !---------------------------------------------------------------------------------------! - ! For enthalpy, we must consider both density and temperature effects. ! + !------ Enthalpy. Density and pressure effects. ---------------------------------------! + curr_can_enthalpy = tq2enthalpy(csite%can_temp(ipa),csite%can_shv(ipa),.true.) + ecurr_denseffect = ddens_dt_effect(old_can_rhos,csite%can_rhos(ipa) & + ,old_can_enthalpy, curr_can_enthalpy & + ,csite%can_depth(ipa),1.0) + ecurr_prsseffect = csite%can_depth(ipa) * (csite%can_prss(ipa) - old_can_prss) !---------------------------------------------------------------------------------------! - old_can_rhotemp = old_can_rhos * old_can_temp - curr_can_rhotemp = csite%can_rhos(ipa) * csite%can_temp(ipa) - old_can_lntheiv = log(old_can_theiv) - curr_can_lntheiv = log(csite%can_theiv(ipa)) - ecurr_denseffect = ddens_dt_effect(old_can_rhotemp,curr_can_rhotemp & - ,old_can_lntheiv,curr_can_lntheiv & - ,csite%can_depth(ipa),cp) + + !---------------------------------------------------------------------------------------! ! Compute the carbon flux components. ! !---------------------------------------------------------------------------------------! @@ -193,20 +265,72 @@ subroutine compute_budget(csite,lsl,pcpg,qpcpg,ipa,wcurr_loss2atm,ecurr_loss2atm ! Compute residuals. ! !---------------------------------------------------------------------------------------! !----- 1. Canopy CO2. ------------------------------------------------------------------! - co2curr_residual = co2budget_deltastorage & - - ( - co2curr_nep - co2curr_loss2atm) & + co2curr_residual = co2budget_deltastorage - ( - co2curr_nep - co2curr_loss2atm ) & - co2curr_denseffect !----- 2. Energy. ----------------------------------------------------------------------! - ecurr_residual = ebudget_deltastorage - ( ecurr_precipgain + ecurr_netrad & - - ecurr_loss2atm - ecurr_loss2drainage & - - ecurr_loss2runoff ) & - - ecurr_denseffect + ecurr_residual = ebudget_deltastorage - ( ecurr_precipgain - ecurr_loss2atm & + - ecurr_loss2drainage - ecurr_loss2runoff & + + ecurr_netrad + ecurr_prsseffect ) & + - ecurr_denseffect !----- 3. Water. -----------------------------------------------------------------------! - wcurr_residual = wbudget_deltastorage - ( wcurr_precipgain - wcurr_loss2atm & - - wcurr_loss2drainage - wcurr_loss2runoff) & - - wcurr_denseffect + wcurr_residual = wbudget_deltastorage - ( wcurr_precipgain - wcurr_loss2atm & + - wcurr_loss2drainage - wcurr_loss2runoff ) & + - wcurr_denseffect !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! + ! Integrate residuals. ! + !---------------------------------------------------------------------------------------! + !----- 1. Canopy CO2. ------------------------------------------------------------------! + csite%co2budget_residual(ipa) = csite%co2budget_residual(ipa) + co2curr_residual + !----- 2. Energy. ----------------------------------------------------------------------! + csite%ebudget_residual(ipa) = csite%ebudget_residual(ipa) + ecurr_residual + !----- 3. Water. -----------------------------------------------------------------------! + csite%wbudget_residual(ipa) = csite%wbudget_residual(ipa) + wcurr_residual + !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! + ! Integrate the terms that are part of the budget. ! + !---------------------------------------------------------------------------------------! + !----- 1. Carbon dioxide. --------------------------------------------------------------! + csite%co2budget_gpp(ipa) = csite%co2budget_gpp(ipa) + gpp * dtlsm + csite%co2budget_gpp_dbh(:,ipa) = csite%co2budget_gpp_dbh(:,ipa) + gpp_dbh(:) * dtlsm + csite%co2budget_plresp(ipa) = csite%co2budget_plresp(ipa) & + + ( leaf_resp + root_resp + growth_resp + storage_resp & + + vleaf_resp ) * dtlsm + csite%co2budget_rh(ipa) = csite%co2budget_rh(ipa) + csite%rh(ipa) * dtlsm + csite%co2budget_denseffect(ipa) = csite%co2budget_denseffect(ipa) + co2curr_denseffect + csite%co2budget_loss2atm(ipa) = csite%co2budget_loss2atm(ipa) + co2curr_loss2atm + !----- 2. Energy. ----------------------------------------------------------------------! + csite%ebudget_precipgain(ipa) = csite%ebudget_precipgain(ipa) + ecurr_precipgain + csite%ebudget_netrad(ipa) = csite%ebudget_netrad(ipa) + ecurr_netrad + csite%ebudget_prsseffect(ipa) = csite%ebudget_prsseffect(ipa) + ecurr_prsseffect + csite%ebudget_denseffect(ipa) = csite%ebudget_denseffect(ipa) + ecurr_denseffect + csite%ebudget_loss2atm(ipa) = csite%ebudget_loss2atm(ipa) + ecurr_loss2atm + csite%ebudget_loss2drainage(ipa) = csite%ebudget_loss2drainage(ipa) & + + ecurr_loss2drainage + csite%ebudget_loss2runoff(ipa) = csite%ebudget_loss2runoff(ipa) & + + ecurr_loss2runoff + !----- 3. Water. -----------------------------------------------------------------------! + csite%wbudget_precipgain(ipa) = csite%wbudget_precipgain(ipa) + wcurr_precipgain + csite%wbudget_denseffect(ipa) = csite%wbudget_denseffect(ipa) + wcurr_denseffect + csite%wbudget_loss2atm(ipa) = csite%wbudget_loss2atm(ipa) + wcurr_loss2atm + csite%wbudget_loss2drainage(ipa) = csite%wbudget_loss2drainage(ipa) & + + wcurr_loss2drainage + csite%wbudget_loss2runoff(ipa) = csite%wbudget_loss2runoff(ipa) & + + wcurr_loss2runoff + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! Update density and initial storage for next step. ! + !---------------------------------------------------------------------------------------! + csite%wbudget_initialstorage(ipa) = wbudget_finalstorage + csite%ebudget_initialstorage(ipa) = ebudget_finalstorage + csite%co2budget_initialstorage(ipa) = co2budget_finalstorage + + !---------------------------------------------------------------------------------------! ! If the "check budget" option is activated (you can turn on and turn off by setting ! ! checkbudget in ed_params.f90), then the model will crash whenever there is some ! @@ -214,45 +338,11 @@ subroutine compute_budget(csite,lsl,pcpg,qpcpg,ipa,wcurr_loss2atm,ecurr_loss2atm !---------------------------------------------------------------------------------------! if (checkbudget) then co2_ok = abs(co2curr_residual) <= rk4eps * ( abs(co2budget_finalstorage) & - + abs(co2budget_deltastorage) * dtlsm) + + abs(co2budget_deltastorage) ) energy_ok = abs(ecurr_residual) <= rk4eps * ( abs(ebudget_finalstorage) & - + abs(ebudget_deltastorage) * dtlsm) + + abs(ebudget_deltastorage) ) water_ok = abs(wcurr_residual) <= rk4eps * ( abs(wbudget_finalstorage) & - + abs(wbudget_deltastorage) * dtlsm) - - if (print_debug) then - write (unit=56,fmt='(i4.4,2(1x,i2.2),1x,f6.0,5(1x,es14.7))') & - current_time%year,current_time%month,current_time%date & - ,current_time%time & - ,co2curr_residual/dtlsm & - ,co2budget_deltastorage/dtlsm & - ,co2curr_nep/dtlsm & - ,co2curr_denseffect/dtlsm & - ,co2curr_loss2atm/dtlsm - - write (unit=66,fmt='(i4.4,2(1x,i2.2),1x,f6.0,8(1x,es14.7))') & - current_time%year,current_time%month,current_time%date & - ,current_time%time & - ,ecurr_residual/dtlsm & - ,ebudget_deltastorage/dtlsm & - ,ecurr_precipgain/dtlsm & - ,ecurr_netrad/dtlsm & - ,ecurr_denseffect/dtlsm & - ,ecurr_loss2atm/dtlsm & - ,ecurr_loss2drainage/dtlsm & - ,ecurr_loss2runoff/dtlsm - - write (unit=76,fmt='(i4.4,2(1x,i2.2),1x,f6.0,7(1x,es14.7))') & - current_time%year,current_time%month,current_time%date & - ,current_time%time & - ,wcurr_residual*day_sec/dtlsm & - ,wbudget_deltastorage*day_sec/dtlsm & - ,wcurr_precipgain*day_sec/dtlsm & - ,wcurr_denseffect*day_sec/dtlsm & - ,wcurr_loss2atm*day_sec/dtlsm & - ,wcurr_loss2drainage*day_sec/dtlsm & - ,wcurr_loss2runoff*day_sec/dtlsm - end if + + abs(wbudget_deltastorage) ) if (.not. co2_ok) then @@ -286,7 +376,7 @@ subroutine compute_budget(csite,lsl,pcpg,qpcpg,ipa,wcurr_loss2atm,ecurr_loss2atm if (.not. energy_ok) then write (unit=*,fmt='(a)') '|-----------------------------------------------------|' - write (unit=*,fmt='(a)') '| !!! ): Energy budget failed :( !!! |' + write (unit=*,fmt='(a)') '| !!! ): Enthalpy budget failed :( !!! |' write (unit=*,fmt='(a)') '|-----------------------------------------------------|' write (unit=*,fmt='(a,i4.4,2(1x,i2.2),1x,f6.0)') ' TIME : ', & current_time%year,current_time%month,current_time%date ,current_time%time @@ -300,6 +390,7 @@ subroutine compute_budget(csite,lsl,pcpg,qpcpg,ipa,wcurr_loss2atm,ecurr_loss2atm write (unit=*,fmt=fmtf ) ' PRECIPGAIN : ',ecurr_precipgain write (unit=*,fmt=fmtf ) ' NETRAD : ',ecurr_netrad write (unit=*,fmt=fmtf ) ' DENSITY_EFFECT : ',ecurr_denseffect + write (unit=*,fmt=fmtf ) ' PRESSURE_EFFECT: ',ecurr_prsseffect write (unit=*,fmt=fmtf ) ' LOSS2ATM : ',ecurr_loss2atm write (unit=*,fmt=fmtf ) ' LOSS2DRAINAGE : ',ecurr_loss2drainage write (unit=*,fmt=fmtf ) ' LOSS2RUNOFF : ',ecurr_loss2runoff @@ -330,62 +421,73 @@ subroutine compute_budget(csite,lsl,pcpg,qpcpg,ipa,wcurr_loss2atm,ecurr_loss2atm write (unit=*,fmt='(a)') ' ' end if - if (.not. (co2_ok .and. energy_ok .and. water_ok)) then - call fatal_error('Budget check has failed, see message above!' & - ,'compute_budget','budget_utils.f90') - end if - end if - !---------------------------------------------------------------------------------------! - ! Integrate residuals. ! - !---------------------------------------------------------------------------------------! - !----- 1. Canopy CO2. ------------------------------------------------------------------! - csite%co2budget_residual(ipa) = csite%co2budget_residual(ipa) + co2curr_residual - !----- 2. Energy. ----------------------------------------------------------------------! - csite%ebudget_residual(ipa) = csite%ebudget_residual(ipa) + ecurr_residual - !----- 3. Water. -----------------------------------------------------------------------! - csite%wbudget_residual(ipa) = csite%wbudget_residual(ipa) + wcurr_residual - !---------------------------------------------------------------------------------------! - !---------------------------------------------------------------------------------------! - ! Integrate the terms that are part of the budget. ! - !---------------------------------------------------------------------------------------! - !----- 1. Carbon dioxide. --------------------------------------------------------------! - csite%co2budget_gpp(ipa) = csite%co2budget_gpp(ipa) + gpp * dtlsm - csite%co2budget_gpp_dbh(:,ipa) = csite%co2budget_gpp_dbh(:,ipa) + gpp_dbh(:) * dtlsm - csite%co2budget_plresp(ipa) = csite%co2budget_plresp(ipa) & - + ( leaf_resp + root_resp + growth_resp + storage_resp & - + vleaf_resp ) * dtlsm - csite%co2budget_rh(ipa) = csite%co2budget_rh(ipa) + csite%rh(ipa) * dtlsm - csite%co2budget_denseffect(ipa) = csite%co2budget_denseffect(ipa) + co2curr_denseffect - csite%co2budget_loss2atm(ipa) = csite%co2budget_loss2atm(ipa) + co2curr_loss2atm - !----- 2. Energy. ----------------------------------------------------------------------! - csite%ebudget_precipgain(ipa) = csite%ebudget_precipgain(ipa) + ecurr_precipgain - csite%ebudget_netrad(ipa) = csite%ebudget_netrad(ipa) + ecurr_netrad - csite%ebudget_denseffect(ipa) = csite%ebudget_denseffect(ipa) + ecurr_denseffect - csite%ebudget_loss2atm(ipa) = csite%ebudget_loss2atm(ipa) + ecurr_loss2atm - csite%ebudget_loss2drainage(ipa) = csite%ebudget_loss2drainage(ipa) & - + ecurr_loss2drainage - csite%ebudget_loss2runoff(ipa) = csite%ebudget_loss2runoff(ipa) & - + ecurr_loss2runoff - !----- 3. Water. -----------------------------------------------------------------------! - csite%wbudget_precipgain(ipa) = csite%wbudget_precipgain(ipa) + wcurr_precipgain - csite%wbudget_denseffect(ipa) = csite%wbudget_denseffect(ipa) + wcurr_denseffect - csite%wbudget_loss2atm(ipa) = csite%wbudget_loss2atm(ipa) + wcurr_loss2atm - csite%wbudget_loss2drainage(ipa) = csite%wbudget_loss2drainage(ipa) & - + wcurr_loss2drainage - csite%wbudget_loss2runoff(ipa) = csite%wbudget_loss2runoff(ipa) & - + wcurr_loss2runoff - !---------------------------------------------------------------------------------------! - !---------------------------------------------------------------------------------------! - ! Update density and initial storage for next step. ! - !---------------------------------------------------------------------------------------! - csite%wbudget_initialstorage(ipa) = wbudget_finalstorage - csite%ebudget_initialstorage(ipa) = ebudget_finalstorage - csite%co2budget_initialstorage(ipa) = co2budget_finalstorage + if (print_budget) then + co2_factor = 1. / dtlsm + ene_factor = 1. / dtlsm + h2o_factor = day_sec / dtlsm + + !----- Fix the units so the terms are expressed as fluxes. -----------------------! + co2curr_residual = co2curr_residual * co2_factor + co2budget_deltastorage = co2budget_deltastorage * co2_factor + co2curr_nep = co2curr_nep * co2_factor + co2curr_denseffect = co2curr_denseffect * co2_factor + co2curr_loss2atm = co2curr_loss2atm * co2_factor + ecurr_residual = ecurr_residual * ene_factor + ebudget_deltastorage = ebudget_deltastorage * ene_factor + ecurr_precipgain = ecurr_precipgain * ene_factor + ecurr_netrad = ecurr_netrad * ene_factor + ecurr_denseffect = ecurr_denseffect * ene_factor + ecurr_prsseffect = ecurr_prsseffect * ene_factor + ecurr_loss2atm = ecurr_loss2atm * ene_factor + ecurr_loss2drainage = ecurr_loss2drainage * ene_factor + ecurr_loss2runoff = ecurr_loss2runoff * ene_factor + wcurr_residual = wcurr_residual * h2o_factor + wbudget_deltastorage = wbudget_deltastorage * h2o_factor + wcurr_precipgain = wcurr_precipgain * h2o_factor + wcurr_denseffect = wcurr_denseffect * h2o_factor + wcurr_loss2atm = wcurr_loss2atm * h2o_factor + wcurr_loss2drainage = wcurr_loss2drainage * h2o_factor + wcurr_loss2runoff = wcurr_loss2runoff * h2o_factor + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! Write the file. ! + !---------------------------------------------------------------------------------! + write(budget_fout,fmt='(2a,i4.4,a)') trim(budget_pref),'patch_',ipa,'.txt' + open (unit=86,file=trim(budget_fout),status='old',action='write' & + ,position='append') + write(unit=86,fmt=bbfmt) & + current_time%year , current_time%month , current_time%date & + , current_time%time , csite%lai(ipa) , csite%wai(ipa) & + , csite%veg_height(ipa) , co2budget_finalstorage , co2curr_residual & + , co2budget_deltastorage , co2curr_nep , co2curr_denseffect & + , co2curr_loss2atm , ebudget_finalstorage , ecurr_residual & + , ebudget_deltastorage , ecurr_precipgain , ecurr_netrad & + , ecurr_denseffect , ecurr_prsseffect , ecurr_loss2atm & + , ecurr_loss2drainage , ecurr_loss2runoff , wbudget_finalstorage & + , wcurr_residual , wbudget_deltastorage , wcurr_precipgain & + , wcurr_denseffect , wcurr_loss2atm , wcurr_loss2drainage & + , wcurr_loss2runoff + close(unit=86,status='keep') + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Stop the run in case there is any leak of CO2, enthalpy, or water. ! + !------------------------------------------------------------------------------------! + if (.not. (co2_ok .and. energy_ok .and. water_ok)) then + call fatal_error('Budget check has failed, see message above!' & + ,'compute_budget','budget_utils.f90') + end if + end if return end subroutine compute_budget @@ -434,8 +536,8 @@ real function compute_water_storage(csite, lsl,ipa) end do !----- 3. Add the water vapour floating in the canopy air space. -----------------------! compute_water_storage = compute_water_storage & - + csite%can_shv(ipa) * csite%can_depth(ipa) & - * csite%can_rhos(ipa) + + csite%can_shv(ipa) * csite%can_depth(ipa) & + * csite%can_rhos(ipa) !----- 4. Add the water on the leaf and wood surfaces. ---------------------------------! do ico = 1,cpatch%ncohorts compute_water_storage = compute_water_storage + cpatch%leaf_water(ico) @@ -504,13 +606,8 @@ real function compute_energy_storage(csite, lsl, ipa) , patchtype ! ! structure use grid_coms , only : nzg ! ! intent(in) use soil_coms , only : dslz ! ! intent(in) - use consts_coms , only : cp & ! intent(in) - , cliq & ! intent(in) - , cice & ! intent(in) - , alvl & ! intent(in) - , alli & ! intent(in) - , t3ple ! ! intent(in) use rk4_coms , only : toosparse ! ! intent(in) + use therm_lib , only : tq2enthalpy ! ! function implicit none !----- Arguments -----------------------------------------------------------------------! type(sitetype) , target :: csite @@ -524,15 +621,20 @@ real function compute_energy_storage(csite, lsl, ipa) real :: sfcwater_storage real :: cas_storage real :: veg_storage + real :: can_enthalpy !---------------------------------------------------------------------------------------! cpatch => csite%patch(ipa) + !----- 1. Computing internal energy stored at the soil. --------------------------------! soil_storage = 0.0 do k = lsl, nzg soil_storage = soil_storage + csite%soil_energy(k,ipa) * dslz(k) end do + !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! ! 2. Computing internal energy stored at the temporary snow/water sfc. layer. ! ! Converting it to J/m2. @@ -542,11 +644,16 @@ real function compute_energy_storage(csite, lsl, ipa) sfcwater_storage = sfcwater_storage & + csite%sfcwater_energy(k,ipa) * csite%sfcwater_mass(k,ipa) end do + !---------------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------------! - ! 3. Finding and value for canopy air total enthalpy . ! + ! 3. Find and value for canopy air total enthalpy . ! !---------------------------------------------------------------------------------------! - cas_storage = cp * csite%can_rhos(ipa) * csite%can_depth(ipa) * csite%can_theiv(ipa) + can_enthalpy = tq2enthalpy(csite%can_temp(ipa),csite%can_shv(ipa),.true.) + cas_storage = csite%can_rhos(ipa) * csite%can_depth(ipa) * can_enthalpy + !---------------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------------! ! 4. Compute the internal energy stored in the plants. ! @@ -555,9 +662,12 @@ real function compute_energy_storage(csite, lsl, ipa) do ico = 1,cpatch%ncohorts veg_storage = veg_storage + cpatch%leaf_energy(ico) + cpatch%wood_energy(ico) end do - + !---------------------------------------------------------------------------------------! + + !----- 5. Integrating the total energy in ED. ------------------------------------------! compute_energy_storage = soil_storage + sfcwater_storage + cas_storage + veg_storage + !---------------------------------------------------------------------------------------! return end function compute_energy_storage diff --git a/ED/src/utils/ed_therm_lib.f90 b/ED/src/utils/ed_therm_lib.f90 index 387e3fa92..028148afd 100644 --- a/ED/src/utils/ed_therm_lib.f90 +++ b/ED/src/utils/ed_therm_lib.f90 @@ -118,22 +118,20 @@ end subroutine calc_veg_hcap ! ! ! We look at leaf and wood separately, but the idea is the same. When heat ! ! capacity is zero (i.e., no leaves or not solving branchwood thermodynamics), we ! - ! cannot find the temperature using qwtk because it is a singularity. Notice that this ! - ! is different skipping when cohorts are not resolvable... If the cohort is not ! - ! resolvable but still has some heat capacity, we should update internal energy using ! - ! the traditional method, and NEVER force the heat capacity to be zero, otherwise we ! - ! violate the fact that heat capacity is a linear function of mass and this will cause ! - ! problems during the fusion/splitting process. ! + ! cannot find the temperature using uextcm2tl because it is a singularity. Notice that ! + ! this is different than skipping when cohorts are not resolvable... If the cohort is ! + ! not resolvable but still has some heat capacity, we should update internal energy ! + ! using the traditional method, and NEVER force the heat capacity to be zero, otherwise ! + ! we violate the fact that heat capacity is a linear function of mass and this will ! + ! cause problems during the fusion/splitting process. ! ! ! ! The "cweh" mean "consistent water&energy&hcap" assumption ! !---------------------------------------------------------------------------------------! subroutine update_veg_energy_cweh(csite,ipa,ico,old_leaf_hcap,old_wood_hcap) - use ed_state_vars, only : sitetype & ! Structure - , patchtype ! ! Structure - use therm_lib , only : qwtk ! ! subroutine - use consts_coms , only : cliq & ! intent(in) - , cice & ! intent(in) - , tsupercool ! ! intent(in) + use ed_state_vars, only : sitetype & ! structure + , patchtype ! ! structure + use therm_lib , only : uextcm2tl & ! subroutine + , cmtl2uext ! ! function implicit none !----- Arguments --------------------------------------------------------------------! type(sitetype) , target :: csite @@ -180,19 +178,15 @@ subroutine update_veg_energy_cweh(csite,ipa,ico,old_leaf_hcap,old_wood_hcap) ! fraction of water held by leaves, we can recalculate the internal energy by ! ! just switching the old heat capacity by the new one. ! !---------------------------------------------------------------------------------! - cpatch%leaf_energy(ico) = cpatch%leaf_hcap(ico) * cpatch%leaf_temp(ico) & - + cpatch%leaf_water(ico) & - * ( cliq * cpatch%leaf_fliq(ico) & - * (cpatch%leaf_temp(ico) - tsupercool) & - + cice * (1.-cpatch%leaf_fliq(ico)) & - * cpatch%leaf_temp(ico)) + cpatch%leaf_energy(ico) = cmtl2uext(cpatch%leaf_hcap(ico),cpatch%leaf_water(ico) & + ,cpatch%leaf_temp(ico),cpatch%leaf_fliq(ico) ) !---------------------------------------------------------------------------------! !----- This is a sanity check, it can be removed if it doesn't crash. ------------! - call qwtk(cpatch%leaf_energy(ico),cpatch%leaf_water(ico),cpatch%leaf_hcap(ico) & - ,new_temp,new_fliq) + call uextcm2tl(cpatch%leaf_energy(ico),cpatch%leaf_water(ico) & + ,cpatch%leaf_hcap(ico),new_temp,new_fliq) !---------------------------------------------------------------------------------! @@ -248,19 +242,15 @@ subroutine update_veg_energy_cweh(csite,ipa,ico,old_leaf_hcap,old_wood_hcap) ! fraction of water held by leaves, we can recalculate the internal energy by ! ! just switching the old heat capacity by the new one. ! !---------------------------------------------------------------------------------! - cpatch%wood_energy(ico) = cpatch%wood_hcap(ico) * cpatch%wood_temp(ico) & - + cpatch%wood_water(ico) & - * ( cliq * cpatch%wood_fliq(ico) & - * (cpatch%wood_temp(ico) - tsupercool) & - + cice * (1.-cpatch%wood_fliq(ico)) & - * cpatch%wood_temp(ico)) + cpatch%wood_energy(ico) = cmtl2uext(cpatch%wood_hcap(ico),cpatch%wood_water(ico) & + ,cpatch%wood_temp(ico),cpatch%wood_fliq (ico) ) !---------------------------------------------------------------------------------! !----- This is a sanity check, it can be removed if it doesn't crash. ------------! - call qwtk(cpatch%wood_energy(ico),cpatch%wood_water(ico),cpatch%wood_hcap(ico) & - ,new_temp,new_fliq) + call uextcm2tl(cpatch%wood_energy(ico),cpatch%wood_water(ico) & + ,cpatch%wood_hcap(ico),new_temp,new_fliq) !---------------------------------------------------------------------------------! @@ -334,7 +324,7 @@ subroutine ed_grndvap(ksn,nsoil,topsoil_water,topsoil_temp,topsoil_fliq,sfcwater , gorh2o & ! intent(in) , lnexp_min & ! intent(in) , huge_num ! ! intent(in) - use therm_lib , only : rslif ! ! function + use therm_lib , only : qslif ! ! function implicit none !----- Arguments --------------------------------------------------------------------! integer , intent(in) :: ksn ! # of surface water layers [ ----] @@ -377,8 +367,7 @@ subroutine ed_grndvap(ksn,nsoil,topsoil_water,topsoil_temp,topsoil_fliq,sfcwater ground_temp = topsoil_temp ground_fliq = topsoil_fliq !----- Compute the saturation specific humidity at ground temperature. -----------! - ground_ssh = rslif(can_prss,ground_temp) - ground_ssh = ground_ssh / (1.0 + ground_ssh) + ground_ssh = qslif(can_prss,ground_temp) !----- Determine alpha. ----------------------------------------------------------! slpotvn = soil(nsoil)%slpots & / (topsoil_water / soil(nsoil)%slmsts) ** soil(nsoil)%slbs @@ -464,8 +453,7 @@ subroutine ed_grndvap(ksn,nsoil,topsoil_water,topsoil_temp,topsoil_fliq,sfcwater ground_temp = sfcwater_temp ground_fliq = sfcwater_fliq !----- Compute the saturation specific humidity at ground temperature. -----------! - ground_ssh = rslif(can_prss,ground_temp) - ground_ssh = ground_ssh / (1.0 + ground_ssh) + ground_ssh = qslif(can_prss,ground_temp) !----- The ground specific humidity in this case is just the saturation value. ---! ground_shv = ground_ssh !----- The conductance should be large so it won't contribute to the net value. --! @@ -520,7 +508,7 @@ subroutine ed_grndvap8(ksn,topsoil_water,topsoil_temp,topsoil_fliq,sfcwater_temp , gorh2o8 & ! intent(in) , lnexp_min8 & ! intent(in) , huge_num8 ! ! intent(in) - use therm_lib8 , only : rslif8 ! ! function + use therm_lib8 , only : qslif8 ! ! function use rk4_coms , only : rk4site ! ! intent(in) use grid_coms , only : nzg ! ! intent(in) use ed_max_dims , only : n_pft ! ! intent(in) @@ -612,8 +600,7 @@ subroutine ed_grndvap8(ksn,topsoil_water,topsoil_temp,topsoil_fliq,sfcwater_temp ground_temp = topsoil_temp ground_fliq = topsoil_fliq !----- Compute the saturation specific humidity at ground temperature. -----------! - ground_ssh = rslif8(can_prss,ground_temp) - ground_ssh = ground_ssh / (1.d0 + ground_ssh) + ground_ssh = qslif8(can_prss,ground_temp) !----- Determine alpha. ----------------------------------------------------------! slpotvn = soil8(nsoil)%slpots & / (use_soil_h2o / soil8(nsoil)%slmsts) ** soil8(nsoil)%slbs @@ -699,9 +686,9 @@ subroutine ed_grndvap8(ksn,topsoil_water,topsoil_temp,topsoil_fliq,sfcwater_temp !---------------------------------------------------------------------------------! ground_temp = sfcwater_temp ground_fliq = sfcwater_fliq + !----- Compute the saturation specific humidity at ground temperature. -----------! - ground_ssh = rslif8(can_prss,ground_temp) - ground_ssh = ground_ssh / (1.d0 + ground_ssh) + ground_ssh = qslif8(can_prss,ground_temp) !----- The ground specific humidity in this case is just the saturation value. ---! ground_shv = ground_ssh !----- The conductance should be large so it won't contribute to the net value. --! diff --git a/ED/src/utils/fatal_error.f90 b/ED/src/utils/fatal_error.f90 index 6a3e139e5..7ec564118 100644 --- a/ED/src/utils/fatal_error.f90 +++ b/ED/src/utils/fatal_error.f90 @@ -58,10 +58,10 @@ subroutine opspec_fatal(reason,opssub) include 'mpif.h' write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') '----------------------------------------------------------------------------' + write (unit=*,fmt='(a)') '------------------------------------------------------' write (unit=*,fmt='(3(a,1x))') '>>>> ',trim(opssub),' error! in your namelist!' write (unit=*,fmt='(a,1x,a)') ' ---> Reason: ',trim(reason) - write (unit=*,fmt='(a)') '----------------------------------------------------------------------------' + write (unit=*,fmt='(a)') '------------------------------------------------------' write (unit=*,fmt='(a)') ' ' return end subroutine opspec_fatal @@ -87,13 +87,13 @@ subroutine warning(reason,subr,file) include 'mpif.h' - write(unit=*,fmt='(a)') '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::' - write(unit=*,fmt='(a)') '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::' - write(unit=*,fmt='(a)') '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::' + write(unit=*,fmt='(a)') '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::' + write(unit=*,fmt='(a)') '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::' + write(unit=*,fmt='(a)') '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::' write(unit=*,fmt='(a)') ' ' - write(unit=*,fmt='(a)') '------------------------------------------------------------------' - write(unit=*,fmt='(a)') ' !!! WARNING !!! ' - write(unit=*,fmt='(a)') '------------------------------------------------------------------' + write(unit=*,fmt='(a)') '--------------------------------------------------------------' + write(unit=*,fmt='(a)') ' !!! WARNING !!! ' + write(unit=*,fmt='(a)') '--------------------------------------------------------------' if (nnodetot > 1 .and. mynum /= nnodetot) then write(unit=*,fmt='(a,1x,i5,a)') ' On node: ',mynum,':' elseif (nnodetot > 1) then @@ -103,8 +103,70 @@ subroutine warning(reason,subr,file) write(unit=*,fmt='(a,1x,a)') ' ---> File: ',trim(file) write(unit=*,fmt='(a,1x,a)') ' ---> Subroutine: ',trim(subr) write (unit=*,fmt='(a,1x,a)') ' ---> Reason: ',trim(reason) - write(unit=*,fmt='(a)') '------------------------------------------------------------------' - write(unit=*,fmt='(a)') '------------------------------------------------------------------' + write(unit=*,fmt='(a)') '--------------------------------------------------------------' + write(unit=*,fmt='(a)') '--------------------------------------------------------------' end subroutine warning !==========================================================================================! !==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +subroutine fail_whale(reason,location) + + implicit none + + character(len=*), intent(in) :: reason + character(len=*), intent(in) :: location + + write(unit=*,fmt='(a)') '' + write(unit=*,fmt='(a)') '' + write(unit=*,fmt='(a)') ':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' ___ _ _ ____ ____ ____ _ _ _ _ _ _ _ ____ _ ____ ' + write(unit=*,fmt='(a)') ' | |__| |___ |___ |__| | | | | | |__| |__| | |___ ' + write(unit=*,fmt='(a)') ' | | | |___ | | | | |___ |_|_| | | | | |___ |___ ' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' _ _ ____ ____ ____ ____ ____ ____ _ _ ____ ___ ' + write(unit=*,fmt='(a)') ' |__| |__| [__ | |__/ |__| [__ |__| |___ | \ ' + write(unit=*,fmt='(a)') ' | | | | ___] |___ | \ | | ___] | | |___ |__/ ' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' _ _ _ ___ ____ _ _ ____ _ _ ____ ____ _ _ _ ' + write(unit=*,fmt='(a)') ' | |\ | | | | \_/ | | | | |__/ [__ | |\/| ' + write(unit=*,fmt='(a)') ' | | \| | |__| | |__| |__| | \ ___] | | | ' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' .+shhhhhhhhhhyso/-` ' + write(unit=*,fmt='(a)') ' `.-::///+oooooooooooo+/:.` -hhhhhhhhhhhhhhhhhhhs+. ' + write(unit=*,fmt='(a)') ' -/oyhhhhhhhhhhhhhhhhhhhhhhhhhhhyo:` -hhhhhhhhhhhhhhhhhhhhhhy/ ' + write(unit=*,fmt='(a)') ' -ohhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhs:-oyhhhhhhhhhhhhhhhhhhhhhy- ' + write(unit=*,fmt='(a)') ' -yhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhy/ `-+yhhhhhhhhhhhhhhhhhhh+ ' + write(unit=*,fmt='(a)') ' +hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhy: :yhhhhhhhhhhhhhhhhhho ' + write(unit=*,fmt='(a)') ' ohhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhho` `yhhhhhhhhhhhhhhhhhh+ ' + write(unit=*,fmt='(a)') '/hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhy- .hhhhhhhhhhyshhhhhhh-' + write(unit=*,fmt='(a)') 'yhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhs` +hhhhhhhh: .hhhhhhs' + write(unit=*,fmt='(a)') 'hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh/`yhhhhhy. shhhhhh' + write(unit=*,fmt='(a)') 'hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh+/+o+: :hhhhhhh' + write(unit=*,fmt='(a)') 'hhhhhhhhhhhhhhh::yhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhso////+ohhhhhhhhs' + write(unit=*,fmt='(a)') 'yhhhhhhhhhhhhhh+/yhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh.' + write(unit=*,fmt='(a)') '/hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh: ' + write(unit=*,fmt='(a)') ' ohhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhs. ' + write(unit=*,fmt='(a)') ' /hhhhhhhhhhhoohhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhho- ' + write(unit=*,fmt='(a)') ' `:/+++/////shhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhsosyyyys+:. ' + write(unit=*,fmt='(a)') ' -hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh::+/ ' + write(unit=*,fmt='(a)') ' :/++++yhhhhhhhhhhs++oyhhhhhhhhhhs+++ohhhhhhs+/ohhhhhhhy: ' + write(unit=*,fmt='(a)') ' /shhhhhs+- `:+oso+/. .::- `:///-. ' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a)') ':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::' + + return +end subroutine fail_whale +!==========================================================================================! +!==========================================================================================! diff --git a/ED/src/utils/fuse_fiss_utils.f90 b/ED/src/utils/fuse_fiss_utils.f90 index 7556d314e..19601a73e 100644 --- a/ED/src/utils/fuse_fiss_utils.f90 +++ b/ED/src/utils/fuse_fiss_utils.f90 @@ -221,7 +221,7 @@ subroutine terminate_patches(csite) use ed_state_vars, only : polygontype & ! Structure , sitetype & ! Structure , patchtype ! ! Structure - use disturb_coms , only : min_new_patch_area ! ! intent(in) + use disturb_coms , only : min_patch_area ! ! intent(in) use ed_misc_coms , only : iqoutput & ! intent(in) , imoutput & ! intent(in) , idoutput ! ! intent(in) @@ -249,7 +249,7 @@ subroutine terminate_patches(csite) !------------------------------------------------------------------------------------! elim_area = 0.0 do ipa = 1,csite%npatches - if (csite%area(ipa) < min_new_patch_area) then + if (csite%area(ipa) < min_patch_area) then elim_area = elim_area + csite%area(ipa) remain_table(ipa) = .false. end if @@ -274,8 +274,8 @@ subroutine terminate_patches(csite) ! Renormalize the total area. We must also rescale all extensive properties from ! ! cohorts, since they are per unit area and we are effectively changing the area. ! ! IMPORTANT: Only cohort-level variables that have units per area (m2) should be ! - ! rescaled. Variables whose units are per plant should _NOT_ be included ! - ! here. ! + ! rescaled. Variables whose units are per plant or per leaf area ! + ! (m2_leaf) should _NOT_ be included here. ! !------------------------------------------------------------------------------------! new_area=0. area_scale = 1./(1. - elim_area) @@ -287,7 +287,6 @@ subroutine terminate_patches(csite) do ico = 1, cpatch%ncohorts cpatch%nplant (ico) = cpatch%nplant (ico) * area_scale cpatch%lai (ico) = cpatch%lai (ico) * area_scale - cpatch%wpa (ico) = cpatch%wpa (ico) * area_scale cpatch%wai (ico) = cpatch%wai (ico) * area_scale cpatch%mean_gpp (ico) = cpatch%mean_gpp (ico) * area_scale cpatch%mean_leaf_resp (ico) = cpatch%mean_leaf_resp (ico) * area_scale @@ -295,7 +294,6 @@ subroutine terminate_patches(csite) cpatch%mean_growth_resp (ico) = cpatch%mean_growth_resp (ico) * area_scale cpatch%mean_storage_resp (ico) = cpatch%mean_storage_resp (ico) * area_scale cpatch%mean_vleaf_resp (ico) = cpatch%mean_vleaf_resp (ico) * area_scale - cpatch%Psi_open (ico) = cpatch%Psi_open (ico) * area_scale cpatch%gpp (ico) = cpatch%gpp (ico) * area_scale cpatch%leaf_respiration (ico) = cpatch%leaf_respiration (ico) * area_scale cpatch%root_respiration (ico) = cpatch%root_respiration (ico) * area_scale @@ -356,6 +354,278 @@ end subroutine terminate_patches + !=======================================================================================! + !=======================================================================================! + ! This subroutine will rescale the area of the patches. This is almost the same as ! + ! the terminate_patches subroutine, except that no patch is removed. ! + !---------------------------------------------------------------------------------------! + subroutine rescale_patches(csite) + use ed_state_vars, only : polygontype & ! Structure + , sitetype & ! Structure + , patchtype ! ! Structure + use disturb_coms , only : min_patch_area ! ! intent(in) + use ed_misc_coms , only : iqoutput & ! intent(in) + , imoutput & ! intent(in) + , idoutput ! ! intent(in) + use allometry , only : dbh2bl ! ! function + use ed_max_dims , only : n_dist_types ! ! intent(in) + + implicit none + !----- Arguments --------------------------------------------------------------------! + type(sitetype) , target :: csite ! Current site + !----- Local variables --------------------------------------------------------------! + type(patchtype) , pointer :: cpatch ! Pointer to current site + type(sitetype) , pointer :: tempsite ! Scratch site + integer :: ipa ! Counter + integer :: ico ! Counter + integer :: lu ! Counter + logical :: norescale ! flag whether rescaling + ! is necessary + logical , dimension(:), allocatable :: remain_table! Flag: this patch will remain. + real , dimension(:), allocatable :: old_area ! Area before rescaling + real , dimension(:), allocatable :: elim_area ! Area of removed patches + real :: new_area ! New area, so the sum of + ! all patches is 1. + real , dimension(:), allocatable :: dist_area ! Area of disturbance type + real :: area_scale ! Scaling area factor. + real :: site_area ! Total area. + real , dimension(:), allocatable :: patch_blmax ! Total bleaf_max for patch + real , dimension(:), allocatable :: dist_blmax ! total bleaf per dist type + real , dimension(:), allocatable :: dist_patch ! number of patches per dist + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! No need to re-scale patches if there is a single patch left. ! + !------------------------------------------------------------------------------------! + if (csite%npatches == 1) return + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Loop through all the patches in this site and determine which of these patches ! + ! is too small in area to be valid. These will be removed and the remaining patches ! + ! will be rescaled later to account for this change and changes in biomass ! + !------------------------------------------------------------------------------------! + allocate (remain_table(csite%npatches)) + remain_table(:) = .true. + + allocate (elim_area(n_dist_types)) + elim_area (:) = 0.0 + + do ipa = 1,csite%npatches + if (csite%area(ipa) < min_patch_area) then + lu = csite%dist_type(ipa) + elim_area(lu)= elim_area (lu) + csite%area(ipa) + remain_table(ipa) = .false. + end if + end do + + if ( sum(elim_area) > 0.0 ) then + !----- Use the mask to resize the patch vectors in the current site. ----------------! + allocate(tempsite) + call allocate_sitetype(tempsite,count(remain_table)) + call copy_sitetype_mask(csite,tempsite,remain_table,size(remain_table) & + ,count(remain_table)) + call deallocate_sitetype(csite) + call allocate_sitetype(csite,count(remain_table)) + + remain_table(:) = .false. + remain_table(1:tempsite%npatches) = .true. + call copy_sitetype_mask(tempsite,csite,remain_table(1:tempsite%npatches) & + ,count(remain_table),count(remain_table)) + call deallocate_sitetype(tempsite) + deallocate(tempsite) + end if + + + !------------------------------------------------------------------------------------! + ! Allocate a temporary array that will contain the potential leaf biomass of ! + ! each patch. This is done so phenology doesn't impact the area. ! + !------------------------------------------------------------------------------------! + allocate (patch_blmax(csite%npatches)) + allocate (old_area (csite%npatches)) + patch_blmax(:) = 0.0 + old_area(:) = 0.0 + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Loop through disturbance types, total area per disturbance type will remain ! + ! unchanged. Area of the patches (PFTs) within a disturbance type will be rescaled ! + ! based on their area ! + !------------------------------------------------------------------------------------! + allocate (dist_area(n_dist_types)) + allocate (dist_blmax(n_dist_types)) + allocate (dist_patch(n_dist_types)) + dist_patch(:) = 0.0 + dist_area (:) = 0.0 + dist_blmax(:) = 0.0 + norescale = .true. + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Add the leaf biomass of all sites. ! + !------------------------------------------------------------------------------------! + site_area = 0.0 + do ipa=1,csite%npatches + !----- This patch. ---------------------------------------------------------------! + cpatch => csite%patch(ipa) + + !----- Find the disturbance type. ------------------------------------------------! + lu = csite%dist_type(ipa) + + !---------------------------------------------------------------------------------! + ! ACTUALLY USE LAI MAX INSTEAD OF BLEAF MAX ! + !---------------------------------------------------------------------------------! + do ico = 1,cpatch%ncohorts + patch_blmax(ipa) = patch_blmax(ipa) + cpatch%nplant(ico) * cpatch%sla(ico) & + * dbh2bl(cpatch%dbh(ico),cpatch%pft(ico)) & + * csite%area(ipa) + end do + + dist_area(lu) = dist_area(lu) + csite%area(ipa) + dist_blmax(lu) = dist_blmax(lu) + patch_blmax(ipa) + dist_patch(lu) = dist_patch(lu) + 1 + + norescale = dist_patch(lu) == 1 + site_area = site_area + csite%area(ipa) + end do + dist_area(:) = dist_area(:) / site_area + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! No need to re-scale patches if there is only one patch (or less) per ! + ! per disturbance type. ! + !------------------------------------------------------------------------------------! + if (norescale) return + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Renormalize the total area. We must also rescale all extensive properties from ! + ! cohorts, since they are per unit area and we are effectively changing the area. ! + ! IMPORTANT: Only cohort-level variables that have units per area (m2) should be ! + ! rescaled. Variables whose units are per plant should _NOT_ be included ! + ! here. ! + !------------------------------------------------------------------------------------! + new_area = 0.0 + do ipa = 1,csite%npatches + lu = csite%dist_type(ipa) + !----- Find the new area, based on the fraction of biomass. ----------------------! + area_scale = patch_blmax(ipa) / dist_blmax(lu) * dist_area(lu) & + / csite%area(ipa) + old_area(ipa) = csite%area(ipa) + csite%area(ipa) = csite%area(ipa) * area_scale + new_area = new_area + csite%area(ipa) + + cpatch => csite%patch(ipa) + do ico = 1, cpatch%ncohorts + cpatch%nplant (ico) = cpatch%nplant (ico) * area_scale + cpatch%lai (ico) = cpatch%lai (ico) * area_scale + cpatch%wai (ico) = cpatch%wai (ico) * area_scale + cpatch%mean_gpp (ico) = cpatch%mean_gpp (ico) * area_scale + cpatch%mean_leaf_resp (ico) = cpatch%mean_leaf_resp (ico) * area_scale + cpatch%mean_root_resp (ico) = cpatch%mean_root_resp (ico) * area_scale + cpatch%mean_growth_resp (ico) = cpatch%mean_growth_resp (ico) * area_scale + cpatch%mean_storage_resp (ico) = cpatch%mean_storage_resp (ico) * area_scale + cpatch%mean_vleaf_resp (ico) = cpatch%mean_vleaf_resp (ico) * area_scale + cpatch%Psi_open (ico) = cpatch%Psi_open (ico) * area_scale + cpatch%gpp (ico) = cpatch%gpp (ico) * area_scale + cpatch%leaf_respiration (ico) = cpatch%leaf_respiration (ico) * area_scale + cpatch%root_respiration (ico) = cpatch%root_respiration (ico) * area_scale + cpatch%leaf_water (ico) = cpatch%leaf_water (ico) * area_scale + cpatch%leaf_hcap (ico) = cpatch%leaf_hcap (ico) * area_scale + cpatch%leaf_energy (ico) = cpatch%leaf_energy (ico) * area_scale + cpatch%wood_water (ico) = cpatch%wood_water (ico) * area_scale + cpatch%wood_hcap (ico) = cpatch%wood_hcap (ico) * area_scale + cpatch%wood_energy (ico) = cpatch%wood_energy (ico) * area_scale + cpatch%monthly_dndt (ico) = cpatch%monthly_dndt (ico) * area_scale + cpatch%today_gpp (ico) = cpatch%today_gpp (ico) * area_scale + cpatch%today_nppleaf (ico) = cpatch%today_nppleaf (ico) * area_scale + cpatch%today_nppfroot (ico) = cpatch%today_nppfroot (ico) * area_scale + cpatch%today_nppsapwood (ico) = cpatch%today_nppsapwood (ico) * area_scale + cpatch%today_nppcroot (ico) = cpatch%today_nppcroot (ico) * area_scale + cpatch%today_nppseeds (ico) = cpatch%today_nppseeds (ico) * area_scale + cpatch%today_nppwood (ico) = cpatch%today_nppwood (ico) * area_scale + cpatch%today_nppdaily (ico) = cpatch%today_nppdaily (ico) * area_scale + cpatch%today_gpp_pot (ico) = cpatch%today_gpp_pot (ico) * area_scale + cpatch%today_gpp_max (ico) = cpatch%today_gpp_max (ico) * area_scale + cpatch%today_leaf_resp (ico) = cpatch%today_leaf_resp (ico) * area_scale + cpatch%today_root_resp (ico) = cpatch%today_root_resp (ico) * area_scale + + !----- Crown area shall not exceed one. ---------------------------------------! + cpatch%crown_area (ico) = min(1.,cpatch%crown_area (ico) * area_scale) + if (idoutput > 0 .or. imoutput > 0 .or. iqoutput > 0) then + cpatch%dmean_par_l (ico) = cpatch%dmean_par_l (ico) * area_scale + cpatch%dmean_par_l_beam (ico) = cpatch%dmean_par_l_beam (ico) * area_scale + cpatch%dmean_par_l_diff (ico) = cpatch%dmean_par_l_diff (ico) * area_scale + end if + if (imoutput > 0 .or. iqoutput > 0) then + cpatch%mmean_par_l (ico) = cpatch%mmean_par_l (ico) * area_scale + cpatch%mmean_par_l_beam (ico) = cpatch%mmean_par_l_beam (ico) * area_scale + cpatch%mmean_par_l_diff (ico) = cpatch%mmean_par_l_diff (ico) * area_scale + end if + if (iqoutput > 0) then + cpatch%qmean_par_l (:,ico) = cpatch%qmean_par_l (:,ico) * area_scale + cpatch%qmean_par_l_beam(:,ico) = cpatch%qmean_par_l_beam(:,ico) * area_scale + cpatch%qmean_par_l_diff(:,ico) = cpatch%qmean_par_l_diff(:,ico) * area_scale + end if + end do + end do + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Sanity check: total new area must be 1.0. ! + !------------------------------------------------------------------------------------! + if (abs(new_area-1.0) > 1.e-5) then + write (unit=*,fmt='(a)' ) '---------------------------------------------' + write (unit=*,fmt='(a)' ) ' PATCH BIOMASS:' + write (unit=*,fmt='(a)' ) ' ' + write (unit=*,fmt='(7(1x,a))' ) ' PATCH',' DIST_TYPE',' PATCH_BLMAX' & + ,' DIST_BLMAX',' DIST_AREA',' OLD_AREA' & + ,' NEW_AREA' + do ipa=1,csite%npatches + lu = csite%dist_type(ipa) + write(unit=*,fmt='(2(1x,i12),5(1x,es12.5))') & + ipa,lu,patch_blmax(ipa),dist_blmax(lu),dist_area(lu),old_area(ipa) & + ,csite%area(ipa) + end do + write (unit=*,fmt='(a,1x,es12.5)') ' SITE BIOMASS :',sum(dist_blmax) + write (unit=*,fmt='(a,1x,es12.5)') ' NEW_AREA :',new_area + write (unit=*,fmt='(a)' ) '---------------------------------------------' + call fatal_error('New_area should be 1 but it isn''t!!!','rescale_patches' & + ,'fuse_fiss_utils.f90') + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Free memory before we leave the sub-routine. ! + !------------------------------------------------------------------------------------! + deallocate(patch_blmax) + deallocate(old_area) + deallocate(dist_area) + deallocate(dist_blmax) + deallocate(dist_patch) + deallocate(elim_area) + !------------------------------------------------------------------------------------! + return + end subroutine rescale_patches + !=======================================================================================! + !=======================================================================================! + + + + + + !=======================================================================================! !=======================================================================================! ! This subroutine will perform cohort fusion based on various similarity criteria to ! @@ -365,7 +635,6 @@ end subroutine terminate_patches ! to live with that and accept life is not always fair with those with limited ! ! computational resources. ! !---------------------------------------------------------------------------------------! - subroutine fuse_cohorts(csite,ipa, green_leaf_factor, lsl) use ed_state_vars , only : sitetype & ! Structure @@ -732,12 +1001,12 @@ subroutine split_cohorts(cpatch, green_leaf_factor, lsl) !---------------------------------------------------------------------------! ! Half the densities of the original cohort. All "extensive" variables ! ! need to be rescaled. ! - ! IMPORTANT: Only cohort-level variables that have units per area (m2) ! - ! should be rescaled. Variables whose units are per plant ! - ! should _NOT_ be included here. ! + ! IMPORTANT: Only cohort-level variables that have units per area ! + ! (m2_ground) should be rescaled. Variables whose units are per ! + ! plant or per leaf area (m2_leaf) should _NOT_ be included ! + ! here. ! !---------------------------------------------------------------------------! cpatch%lai (ico) = cpatch%lai (ico) * 0.5 - cpatch%wpa (ico) = cpatch%wpa (ico) * 0.5 cpatch%wai (ico) = cpatch%wai (ico) * 0.5 cpatch%crown_area (ico) = cpatch%crown_area (ico) * 0.5 cpatch%nplant (ico) = cpatch%nplant (ico) * 0.5 @@ -758,7 +1027,6 @@ subroutine split_cohorts(cpatch, green_leaf_factor, lsl) cpatch%today_gpp_max (ico) = cpatch%today_gpp_max (ico) * 0.5 cpatch%today_leaf_resp (ico) = cpatch%today_leaf_resp (ico) * 0.5 cpatch%today_root_resp (ico) = cpatch%today_root_resp (ico) * 0.5 - cpatch%Psi_open (ico) = cpatch%Psi_open (ico) * 0.5 cpatch%gpp (ico) = cpatch%gpp (ico) * 0.5 cpatch%leaf_respiration (ico) = cpatch%leaf_respiration (ico) * 0.5 cpatch%root_respiration (ico) = cpatch%root_respiration (ico) * 0.5 @@ -847,8 +1115,7 @@ end subroutine split_cohorts subroutine clone_cohort(cpatch,isc,idt) use ed_max_dims , only : n_mort ! ! intent(in) - use ed_state_vars, only : patchtype & ! Structure - , stoma_data ! ! Structure + use ed_state_vars, only : patchtype ! ! Structure use ed_misc_coms , only : iqoutput & ! intent(in) , idoutput & ! intent(in) , imoutput ! ! intent(in) @@ -859,7 +1126,6 @@ subroutine clone_cohort(cpatch,isc,idt) integer , intent(in) :: idt ! Index of "Destination" cohort" !----- Local variables --------------------------------------------------------------! integer :: imonth - type(stoma_data), pointer :: osdt,ossc !------------------------------------------------------------------------------------! cpatch%pft(idt) = cpatch%pft(isc) @@ -873,7 +1139,6 @@ subroutine clone_cohort(cpatch,isc,idt) cpatch%phenology_status(idt) = cpatch%phenology_status(isc) cpatch%balive(idt) = cpatch%balive(isc) cpatch%lai(idt) = cpatch%lai(isc) - cpatch%wpa(idt) = cpatch%wpa(isc) cpatch%wai(idt) = cpatch%wai(isc) cpatch%crown_area(idt) = cpatch%crown_area(isc) cpatch%bstorage(idt) = cpatch%bstorage(isc) @@ -889,11 +1154,13 @@ subroutine clone_cohort(cpatch,isc,idt) cpatch%leaf_energy(idt) = cpatch%leaf_energy(isc) cpatch%leaf_hcap(idt) = cpatch%leaf_hcap(isc) cpatch%leaf_temp(idt) = cpatch%leaf_temp(isc) + cpatch%leaf_temp_pv(idt) = cpatch%leaf_temp_pv(isc) cpatch%leaf_fliq(idt) = cpatch%leaf_fliq(isc) cpatch%leaf_water(idt) = cpatch%leaf_water(isc) cpatch%wood_energy(idt) = cpatch%wood_energy(isc) cpatch%wood_hcap(idt) = cpatch%wood_hcap(isc) cpatch%wood_temp(idt) = cpatch%wood_temp(isc) + cpatch%wood_temp_pv(idt) = cpatch%wood_temp_pv(isc) cpatch%wood_fliq(idt) = cpatch%wood_fliq(isc) cpatch%wood_water(idt) = cpatch%wood_water(isc) cpatch%veg_wind(idt) = cpatch%veg_wind(isc) @@ -954,9 +1221,6 @@ subroutine clone_cohort(cpatch,isc,idt) cpatch%light_level(idt) = cpatch%light_level(isc) cpatch%light_level_beam(idt) = cpatch%light_level_beam(isc) cpatch%light_level_diff(idt) = cpatch%light_level_diff(isc) - cpatch%lambda_light(idt) = cpatch%lambda_light(isc) - cpatch%beamext_level(idt) = cpatch%beamext_level(isc) - cpatch%diffext_level(idt) = cpatch%diffext_level(isc) cpatch%leaf_gbh(idt) = cpatch%leaf_gbh(isc) cpatch%leaf_gbw(idt) = cpatch%leaf_gbw(isc) cpatch%wood_gbh(idt) = cpatch%wood_gbh(isc) @@ -986,27 +1250,6 @@ subroutine clone_cohort(cpatch,isc,idt) cpatch%llspan(idt) = cpatch%llspan(isc) cpatch%vm_bar(idt) = cpatch%vm_bar(isc) cpatch%sla(idt) = cpatch%sla(isc) - - cpatch%old_stoma_vector(:,idt) = cpatch%old_stoma_vector(:,isc) - - osdt => cpatch%old_stoma_data(idt) - ossc => cpatch%old_stoma_data(isc) - - osdt%recalc = ossc%recalc - osdt%T_L = ossc%T_L - osdt%e_A = ossc%e_A - osdt%PAR = ossc%PAR - osdt%rb_factor = ossc%rb_factor - osdt%prss = ossc%prss - osdt%phenology_factor = ossc%phenology_factor - osdt%gsw_open = ossc%gsw_open - osdt%ilimit = ossc%ilimit - osdt%T_L_residual = ossc%T_L_residual - osdt%e_a_residual = ossc%e_a_residual - osdt%par_residual = ossc%par_residual - osdt%rb_residual = ossc%rb_residual - osdt%leaf_residual = ossc%leaf_residual - osdt%gsw_residual = ossc%gsw_residual if (idoutput > 0 .or. imoutput > 0 .or. iqoutput > 0) then @@ -1029,12 +1272,9 @@ subroutine clone_cohort(cpatch,isc,idt) cpatch%dmean_psi_open (idt) = cpatch%dmean_psi_open (isc) cpatch%dmean_psi_closed (idt) = cpatch%dmean_psi_closed (isc) cpatch%dmean_water_supply (idt) = cpatch%dmean_water_supply (isc) - cpatch%dmean_lambda_light (idt) = cpatch%dmean_lambda_light (isc) cpatch%dmean_light_level (idt) = cpatch%dmean_light_level (isc) cpatch%dmean_light_level_beam(idt) = cpatch%dmean_light_level_beam(isc) cpatch%dmean_light_level_diff(idt) = cpatch%dmean_light_level_diff(isc) - cpatch%dmean_beamext_level (idt) = cpatch%dmean_beamext_level (isc) - cpatch%dmean_diffext_level (idt) = cpatch%dmean_diffext_level (isc) end if if (imoutput > 0 .or. iqoutput > 0) then @@ -1051,12 +1291,9 @@ subroutine clone_cohort(cpatch,isc,idt) cpatch%mmean_root_maintenance (idt) = cpatch%mmean_root_maintenance (isc) cpatch%mmean_leaf_drop (idt) = cpatch%mmean_leaf_drop (isc) cpatch%mmean_cb (idt) = cpatch%mmean_cb (isc) - cpatch%mmean_lambda_light (idt) = cpatch%mmean_lambda_light (isc) cpatch%mmean_light_level (idt) = cpatch%mmean_light_level (isc) cpatch%mmean_light_level_beam (idt) = cpatch%mmean_light_level_beam (isc) cpatch%mmean_light_level_diff (idt) = cpatch%mmean_light_level_diff (isc) - cpatch%mmean_beamext_level (idt) = cpatch%mmean_beamext_level (isc) - cpatch%mmean_diffext_level (idt) = cpatch%mmean_diffext_level (isc) cpatch%mmean_gpp (idt) = cpatch%mmean_gpp (isc) cpatch%mmean_nppleaf (idt) = cpatch%mmean_nppleaf (isc) cpatch%mmean_nppfroot (idt) = cpatch%mmean_nppfroot (isc) @@ -1110,8 +1347,8 @@ subroutine fuse_2_cohorts(cpatch,donc,recc, newn,green_leaf_factor, can_prss,lsl use ed_state_vars , only : patchtype ! ! Structure use pft_coms , only : q & ! intent(in), lookup table , qsw ! ! intent(in), lookup table - use therm_lib , only : qwtk & ! subroutine - , rslif ! ! function + use therm_lib , only : uextcm2tl & ! subroutine + , qslif ! ! function use allometry , only : dbh2krdepth & ! function , bd2dbh & ! function , dbh2h ! ! function @@ -1203,7 +1440,6 @@ subroutine fuse_2_cohorts(cpatch,donc,recc, newn,green_leaf_factor, can_prss,lsl end if !------------------------------------------------------------------------------------! - cpatch%wpa (recc) = cpatch%wpa(recc) + cpatch%wpa (donc) cpatch%wai (recc) = cpatch%wai(recc) + cpatch%wai (donc) cpatch%crown_area (recc) = min(1.,cpatch%crown_area(recc) + cpatch%crown_area(donc)) cpatch%leaf_energy(recc) = cpatch%leaf_energy(recc) + cpatch%leaf_energy(donc) @@ -1221,31 +1457,41 @@ subroutine fuse_2_cohorts(cpatch,donc,recc, newn,green_leaf_factor, can_prss,lsl !------------------------------------------------------------------------------------! if ( cpatch%leaf_hcap(recc) > 0. ) then !----- Update temperature using the standard thermodynamics. ---------------------! - call qwtk(cpatch%leaf_energy(recc),cpatch%leaf_water(recc),cpatch%leaf_hcap(recc) & - ,cpatch%leaf_temp(recc),cpatch%leaf_fliq(recc)) + call uextcm2tl(cpatch%leaf_energy(recc),cpatch%leaf_water(recc) & + ,cpatch%leaf_hcap(recc),cpatch%leaf_temp(recc) & + ,cpatch%leaf_fliq(recc)) + + else - !----- Leaf temperature cannot be found using qwtk, this is a singularity. -------! + !----- Leaf temperature cannot be found using uextcm2tl, this is a singularity. --! cpatch%leaf_temp(recc) = newni & * ( cpatch%leaf_temp(recc) * cpatch%nplant(recc) & + cpatch%leaf_temp(donc) * cpatch%nplant(donc)) cpatch%leaf_fliq(recc) = 0.0 end if + + !----- Simply set the previous time-steps temp as the current + + if ( cpatch%wood_hcap(recc) > 0. ) then !----- Update temperature using the standard thermodynamics. ---------------------! - call qwtk(cpatch%wood_energy(recc),cpatch%wood_water(recc),cpatch%wood_hcap(recc) & - ,cpatch%wood_temp(recc),cpatch%wood_fliq(recc)) + call uextcm2tl(cpatch%wood_energy(recc),cpatch%wood_water(recc) & + ,cpatch%wood_hcap(recc),cpatch%wood_temp(recc) & + ,cpatch%wood_fliq(recc)) else - !----- Wood temperature cannot be found using qwtk, this is a singularity. -------! + !----- Wood temperature cannot be found using uextcm2tl, this is a singularity. --! cpatch%wood_temp(recc) = newni & * ( cpatch%wood_temp(recc) * cpatch%nplant(recc) & + cpatch%wood_temp(donc) * cpatch%nplant(donc)) cpatch%wood_fliq(recc) = 0.0 end if - !------------------------------------------------------------------------------------! + + !----- Set time-steps temp as the current + cpatch%leaf_temp_pv(recc) = cpatch%leaf_temp(recc) + cpatch%wood_temp_pv(recc) = cpatch%wood_temp(recc) !------ Find the intercellular value assuming saturation. ---------------------------! - cpatch%lint_shv(recc) = rslif(can_prss,cpatch%leaf_temp(recc)) - cpatch%lint_shv(recc) = cpatch%lint_shv(recc) / (1. + cpatch%lint_shv(recc)) + cpatch%lint_shv(recc) = qslif(can_prss,cpatch%leaf_temp(recc)) cb_act = 0. cb_max = 0. @@ -1385,12 +1631,6 @@ subroutine fuse_2_cohorts(cpatch,donc,recc, newn,green_leaf_factor, can_prss,lsl cpatch%light_level_diff(recc) = ( cpatch%light_level_diff(recc) *cpatch%nplant(recc) & + cpatch%light_level_diff(donc) *cpatch%nplant(donc))& * newni - cpatch%beamext_level(recc) = ( cpatch%beamext_level(recc) *cpatch%nplant(recc) & - + cpatch%beamext_level(donc) *cpatch%nplant(donc) ) & - * newni - cpatch%diffext_level(recc) = ( cpatch%diffext_level(recc) *cpatch%nplant(recc) & - + cpatch%diffext_level(donc) *cpatch%nplant(donc) ) & - * newni !------------------------------------------------------------------------------------! @@ -1412,15 +1652,19 @@ subroutine fuse_2_cohorts(cpatch,donc,recc, newn,green_leaf_factor, can_prss,lsl cpatch%vleaf_respiration(recc) = newni * & ( cpatch%vleaf_respiration(recc) * cpatch%nplant(recc) & + cpatch%vleaf_respiration(donc) * cpatch%nplant(donc) ) + !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! - ! Water demand and supply are in kg/m2_gnd/s, so we add them. ! + ! Water demand is in kg/m2_leaf/s, so we scale them by LAI. Water supply is in ! + ! kg/m2_ground/s, so we just add them. ! !------------------------------------------------------------------------------------! - cpatch%psi_open(recc) = cpatch%psi_open(recc) + cpatch%psi_open(donc) - cpatch%psi_closed(recc) = cpatch%psi_closed(recc) + cpatch%psi_closed(donc) + cpatch%psi_open (recc) = ( cpatch%psi_open (recc) * cpatch%lai(recc) & + + cpatch%psi_open (donc) * cpatch%lai(donc) ) * newlaii + cpatch%psi_closed (recc) = ( cpatch%psi_closed(recc) * cpatch%lai(recc) & + + cpatch%psi_closed(donc) * cpatch%lai(donc) ) * newlaii cpatch%water_supply(recc) = cpatch%water_supply(recc) + cpatch%water_supply(donc) !------------------------------------------------------------------------------------! @@ -1429,15 +1673,15 @@ subroutine fuse_2_cohorts(cpatch,donc,recc, newn,green_leaf_factor, can_prss,lsl ! Carbon demand is in kg_C/m2_leaf/s, so we scale them by LAI. FSW and FSN are ! ! really related to leaves, so we scale them by LAI. ! !------------------------------------------------------------------------------------! - cpatch%A_open(recc) = ( cpatch%A_open(recc) * cpatch%lai(recc) & - + cpatch%A_open(donc) * cpatch%lai(donc) ) * newlaii + cpatch%A_open (recc) = ( cpatch%A_open (recc) * cpatch%lai(recc) & + + cpatch%A_open (donc) * cpatch%lai(donc) ) * newlaii cpatch%A_closed(recc) = ( cpatch%A_closed(recc) * cpatch%lai(recc) & + cpatch%A_closed(donc) * cpatch%lai(donc) ) * newlaii - cpatch%fsw(recc) = ( cpatch%fsw(recc) * cpatch%lai(recc) & - + cpatch%fsw(donc) * cpatch%lai(donc) ) * newlaii - cpatch%fsn(recc) = ( cpatch%fsn(recc) * cpatch%lai(recc) & - + cpatch%fsn(donc) * cpatch%lai(donc) ) * newlaii - cpatch%fs_open(recc) = cpatch%fsw(recc) * cpatch%fsn(recc) + cpatch%fsw (recc) = ( cpatch%fsw (recc) * cpatch%lai(recc) & + + cpatch%fsw (donc) * cpatch%lai(donc) ) * newlaii + cpatch%fsn (recc) = ( cpatch%fsn (recc) * cpatch%lai(recc) & + + cpatch%fsn (donc) * cpatch%lai(donc) ) * newlaii + cpatch%fs_open (recc) = cpatch%fsw(recc) * cpatch%fsn(recc) !------------------------------------------------------------------------------------! @@ -1544,18 +1788,6 @@ subroutine fuse_2_cohorts(cpatch,donc,recc, newn,green_leaf_factor, can_prss,lsl * cpatch%nplant(recc) & + cpatch%dmean_light_level_diff(donc) & * cpatch%nplant(donc) ) * newni - cpatch%dmean_beamext_level (recc) = ( cpatch%dmean_beamext_level(recc) & - * cpatch%nplant(recc) & - + cpatch%dmean_beamext_level(donc) & - * cpatch%nplant(donc) ) * newni - cpatch%dmean_diffext_level (recc) = ( cpatch%dmean_diffext_level(recc) & - * cpatch%nplant(recc) & - + cpatch%dmean_diffext_level(donc) & - * cpatch%nplant(donc) ) * newni - cpatch%dmean_lambda_light (recc) = ( cpatch%dmean_lambda_light(recc) & - * cpatch%nplant(recc) & - + cpatch%dmean_lambda_light(donc) & - * cpatch%nplant(donc) ) * newni cpatch%dmean_gpp (recc) = ( cpatch%dmean_gpp(recc) & * cpatch%nplant(recc) & + cpatch%dmean_gpp(donc) & @@ -1645,18 +1877,6 @@ subroutine fuse_2_cohorts(cpatch,donc,recc, newn,green_leaf_factor, can_prss,lsl * cpatch%nplant(recc) & + cpatch%mmean_light_level_diff(donc) & * cpatch%nplant(donc) ) * newni - cpatch%mmean_beamext_level (recc) = ( cpatch%mmean_beamext_level(recc) & - * cpatch%nplant(recc) & - + cpatch%mmean_beamext_level(donc) & - * cpatch%nplant(donc) ) * newni - cpatch%mmean_diffext_level (recc) = ( cpatch%mmean_diffext_level(recc) & - * cpatch%nplant(recc) & - + cpatch%mmean_diffext_level(donc) & - * cpatch%nplant(donc) ) * newni - cpatch%mmean_lambda_light (recc) = ( cpatch%mmean_lambda_light(recc) & - * cpatch%nplant(recc) & - + cpatch%mmean_lambda_light(donc) & - * cpatch%nplant(donc) ) * newni cpatch%mmean_leaf_maintenance(recc) = ( cpatch%mmean_leaf_maintenance(recc) & * cpatch%nplant(recc) & + cpatch%mmean_leaf_maintenance(donc) & @@ -2991,10 +3211,7 @@ subroutine fuse_2_patches(csite,donp,recp,mzg,mzs,prss,lsl,ntext_soil,green_leaf use ed_max_dims , only : n_pft & ! intent(in) , n_dbh ! ! intent(in) use mem_polygons , only : maxcohort ! ! intent(in) - use consts_coms , only : cpi & ! intent(in) - , cpor & ! intent(in) - , p00 ! ! intent(in) - use therm_lib , only : qwtk ! ! function + use therm_lib , only : uextcm2tl ! ! function use ed_misc_coms , only : iqoutput & ! intent(in) , idoutput & ! intent(in) , imoutput & ! intent(in) @@ -3085,6 +3302,10 @@ subroutine fuse_2_patches(csite,donp,recp,mzg,mzs,prss,lsl,ntext_soil,green_leaf ( csite%can_theta(donp) * csite%area(donp) & + csite%can_theta(recp) * csite%area(recp) ) + csite%can_temp_pv(recp) = newareai * & + ( csite%can_temp_pv(donp) * csite%area(donp) & + + csite%can_temp_pv(recp) * csite%area(recp) ) + csite%can_theiv(recp) = newareai * & ( csite%can_theiv(donp) * csite%area(donp) & + csite%can_theiv(recp) * csite%area(recp) ) @@ -3326,10 +3547,6 @@ subroutine fuse_2_patches(csite,donp,recp,mzg,mzs,prss,lsl,ntext_soil,green_leaf ( csite%avg_drainage(donp) * csite%area(donp) & + csite%avg_drainage(recp) * csite%area(recp) ) - csite%aux(recp) = newareai * & - ( csite%aux(donp) * csite%area(donp) & - + csite%aux(recp) * csite%area(recp) ) - csite%avg_sensible_lc(recp) = newareai * & ( csite%avg_sensible_lc(donp) * csite%area(donp) & + csite%avg_sensible_lc(recp) * csite%area(recp) ) @@ -3418,6 +3635,10 @@ subroutine fuse_2_patches(csite,donp,recp,mzg,mzs,prss,lsl,ntext_soil,green_leaf ( csite%ebudget_residual(donp) * csite%area(donp) & + csite%ebudget_residual(recp) * csite%area(recp) ) + csite%ebudget_netrad(recp) = newareai * & + ( csite%ebudget_netrad (donp) * csite%area(donp) & + + csite%ebudget_netrad (recp) * csite%area(recp) ) + csite%ebudget_loss2atm(recp) = newareai * & ( csite%ebudget_loss2atm(donp) * csite%area(donp) & + csite%ebudget_loss2atm(recp) * csite%area(recp) ) @@ -3426,6 +3647,10 @@ subroutine fuse_2_patches(csite,donp,recp,mzg,mzs,prss,lsl,ntext_soil,green_leaf ( csite%ebudget_denseffect(donp) * csite%area(donp) & + csite%ebudget_denseffect(recp) * csite%area(recp) ) + csite%ebudget_prsseffect(recp) = newareai * & + ( csite%ebudget_prsseffect(donp) * csite%area(donp) & + + csite%ebudget_prsseffect(recp) * csite%area(recp) ) + csite%ebudget_loss2runoff(recp) = newareai * & ( csite%ebudget_loss2runoff(donp) * csite%area(donp) & + csite%ebudget_loss2runoff(recp) * csite%area(recp) ) @@ -3434,9 +3659,6 @@ subroutine fuse_2_patches(csite,donp,recp,mzg,mzs,prss,lsl,ntext_soil,green_leaf ( csite%ebudget_loss2drainage(donp) * csite%area(donp) & + csite%ebudget_loss2drainage(recp) * csite%area(recp) ) - csite%ebudget_netrad(recp) = newareai * & - ( csite%ebudget_netrad(donp) * csite%area(donp) & - + csite%ebudget_netrad(recp) * csite%area(recp) ) csite%ebudget_precipgain(recp) = newareai * & ( csite%ebudget_precipgain(donp) * csite%area(donp) & @@ -3476,10 +3698,6 @@ subroutine fuse_2_patches(csite,donp,recp,mzg,mzs,prss,lsl,ntext_soil,green_leaf ( csite%avg_transloss(iii,donp) * csite%area(donp) & + csite%avg_transloss(iii,recp) * csite%area(recp) ) - csite%aux_s(iii,recp) = newareai * & - ( csite%aux_s(iii,donp) * csite%area(donp) & - + csite%aux_s(iii,recp) * csite%area(recp) ) - csite%avg_sensible_gg(iii,recp) = newareai * & ( csite%avg_sensible_gg(iii,donp) * csite%area(donp) & + csite%avg_sensible_gg(iii,recp) * csite%area(recp) ) @@ -3515,11 +3733,6 @@ subroutine fuse_2_patches(csite,donp,recp,mzg,mzs,prss,lsl,ntext_soil,green_leaf * csite%area(donp) & + csite%dmean_water_residual(recp) & * csite%area(recp) ) - csite%dmean_lambda_light(recp) = newareai & - * ( csite%dmean_lambda_light(donp) & - * csite%area(donp) & - + csite%dmean_lambda_light(recp) & - * csite%area(recp) ) csite%dmean_A_decomp(recp) = newareai & * ( csite%dmean_A_decomp(donp) & * csite%area(donp) & @@ -3556,11 +3769,6 @@ subroutine fuse_2_patches(csite,donp,recp,mzg,mzs,prss,lsl,ntext_soil,green_leaf * csite%area(donp) & + csite%mmean_water_residual(recp) & * csite%area(recp) ) - csite%mmean_lambda_light(recp) = newareai & - * ( csite%mmean_lambda_light(donp) & - * csite%area(donp) & - + csite%mmean_lambda_light(recp) & - * csite%area(recp) ) csite%mmean_A_decomp(recp) = newareai & * ( csite%mmean_A_decomp(donp) & * csite%area(donp) & @@ -3594,9 +3802,9 @@ subroutine fuse_2_patches(csite,donp,recp,mzg,mzs,prss,lsl,ntext_soil,green_leaf ! user may have disabled branchwood thermodynamics. ! !------------------------------------------------------------------------------------! if (csite%avg_leaf_hcap(recp) > 0.) then - call qwtk(csite%avg_leaf_energy(recp),csite%avg_leaf_water(recp) & - ,csite%avg_leaf_hcap(recp),csite%avg_leaf_temp(recp) & - ,csite%avg_leaf_fliq(recp)) + call uextcm2tl(csite%avg_leaf_energy(recp),csite%avg_leaf_water(recp) & + ,csite%avg_leaf_hcap(recp),csite%avg_leaf_temp(recp) & + ,csite%avg_leaf_fliq(recp)) else csite%avg_leaf_temp(recp) = newareai & * ( csite%avg_leaf_temp(donp) * csite%area(donp) & @@ -3606,9 +3814,9 @@ subroutine fuse_2_patches(csite,donp,recp,mzg,mzs,prss,lsl,ntext_soil,green_leaf + csite%avg_leaf_fliq(recp) * csite%area(recp) ) end if if (csite%avg_wood_hcap(recp) > 0.) then - call qwtk(csite%avg_wood_energy(recp),csite%avg_wood_water(recp) & - ,csite%avg_wood_hcap(recp),csite%avg_wood_temp(recp) & - ,csite%avg_wood_fliq(recp)) + call uextcm2tl(csite%avg_wood_energy(recp),csite%avg_wood_water(recp) & + ,csite%avg_wood_hcap(recp),csite%avg_wood_temp(recp) & + ,csite%avg_wood_fliq(recp)) else csite%avg_wood_temp(recp) = newareai & * ( csite%avg_wood_temp(donp) * csite%area(donp) & @@ -3643,7 +3851,6 @@ subroutine fuse_2_patches(csite,donp,recp,mzg,mzs,prss,lsl,ntext_soil,green_leaf !------------------------------------------------------------------------------------! do ico = 1,nrc cpatch%lai (ico) = cpatch%lai (ico) * area_scale - cpatch%wpa (ico) = cpatch%wpa (ico) * area_scale cpatch%wai (ico) = cpatch%wai (ico) * area_scale cpatch%nplant (ico) = cpatch%nplant (ico) * area_scale cpatch%mean_gpp (ico) = cpatch%mean_gpp (ico) * area_scale @@ -3704,7 +3911,6 @@ subroutine fuse_2_patches(csite,donp,recp,mzg,mzs,prss,lsl,ntext_soil,green_leaf !------------------------------------------------------------------------------------! do ico = 1,ndc cpatch%lai (ico) = cpatch%lai (ico) * area_scale - cpatch%wpa (ico) = cpatch%wpa (ico) * area_scale cpatch%wai (ico) = cpatch%wai (ico) * area_scale cpatch%nplant (ico) = cpatch%nplant (ico) * area_scale cpatch%mean_gpp (ico) = cpatch%mean_gpp (ico) * area_scale diff --git a/ED/src/utils/numutils.f90 b/ED/src/utils/numutils.f90 index 40e18b0f1..e3571e01f 100644 --- a/ED/src/utils/numutils.f90 +++ b/ED/src/utils/numutils.f90 @@ -1,139 +1,103 @@ -!############################# Change Log ################################## -! 2.0.0 -! -!########################################################################### -! Copyright (C) 1990, 1995, 1999, 2000, 2003 - All Rights Reserved -! Regional Atmospheric Modeling System - RAMS -!########################################################################### +!==========================================================================================! +!==========================================================================================! +! Change Log ! +! 2.0.0 ! +! ! +!------------------------------------------------------------------------------------------! +! Copyright (C) 1990, 1995, 1999, 2000, 2003 - All Rights Reserved ! +! Regional Atmospheric Modeling System - RAMS ! +!==========================================================================================! +!==========================================================================================! -subroutine azerov(n1) -implicit none -integer :: n,n1 -real :: a1(n1),a2(n1),a3(n1),a4(n1),a5(n1) -entry azero(n1,a1) - do n=1,n1 - a1(n)=0. - enddo -return -entry azero2(n1,a1,a2) - do n=1,n1 - a1(n)=0. - a2(n)=0. - enddo -return -entry azero3(n1,a1,a2,a3) - do n=1,n1 - a1(n)=0. - a2(n)=0. - a3(n)=0. - enddo -return -entry azero4(n1,a1,a2,a3,a4) - do n=1,n1 - a1(n)=0. - a2(n)=0. - a3(n)=0. - a4(n)=0. - enddo -return -entry azero5(n1,a1,a2,a3,a4,a5) - do n=1,n1 - a1(n)=0. - a2(n)=0. - a3(n)=0. - a4(n)=0. - a5(n)=0. - enddo -return -end -![MLO ---- Similar to azerov, but for integers. -subroutine izerov(n1) - implicit none - integer :: n,n1 - integer :: ijk1(n1),ijk2(n1),ijk3(n1),ijk4(n1),ijk5(n1) - entry izero(n1,ijk1) - do n=1,n1 - ijk1(n)=0 - enddo - return - entry izero2(n1,ijk1,ijk2) - do n=1,n1 - ijk1(n)=0 - ijk2(n)=0 - enddo - return - entry izero3(n1,ijk1,ijk2,ijk3) - do n=1,n1 - ijk1(n)=0 - ijk2(n)=0 - ijk3(n)=0 - enddo - return - entry izero4(n1,ijk1,ijk2,ijk3,ijk4) - do n=1,n1 - ijk1(n)=0 - ijk2(n)=0 - ijk3(n)=0 - ijk4(n)=0 - enddo - return - entry izero5(n1,ijk1,ijk2,ijk3,ijk4,ijk5) - do n=1,n1 - ijk1(n)=0 - ijk2(n)=0 - ijk3(n)=0 - ijk4(n)=0 - ijk5(n)=0 - enddo - return -end subroutine izerov -![MLO - Just to generate a matrix full of ones... -subroutine aonev(n1) -implicit none -integer :: n,n1 -real :: a1(n1),a2(n1),a3(n1),a4(n1),a5(n1) -entry aone(n1,a1) - do n=1,n1 - a1(n)=1. - enddo -return -entry aone2(n1,a1,a2) - do n=1,n1 - a1(n)=1. - a2(n)=1. - enddo -return -entry aone3(n1,a1,a2,a3) - do n=1,n1 - a1(n)=1. - a2(n)=1. - a3(n)=1. - enddo -return -entry aone4(n1,a1,a2,a3,a4) - do n=1,n1 - a1(n)=1. - a2(n)=1. - a3(n)=1. - a4(n)=1. - enddo -return -entry aone5(n1,a1,a2,a3,a4,a5) - do n=1,n1 - a1(n)=1. - a2(n)=1. - a3(n)=1. - a4(n)=1. - a5(n)=1. - enddo -return -end subroutine aonev -!MLO] +!==========================================================================================! +!==========================================================================================! +! This sub-routine flushes all elements of this array to zero. Legacy from the old ! +! code, when vector operations didn't exist. ! +!------------------------------------------------------------------------------------------! +subroutine azero(nmax,arr) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: nmax + real , dimension(nmax), intent(out) :: arr + !----- Local variables. ----------------------------------------------------------------! + integer :: n + !---------------------------------------------------------------------------------------! + do n=1,nmax + arr(n) = 0. + end do + + return +end subroutine azero +!==========================================================================================! +!==========================================================================================! + + + + + +!==========================================================================================! +!==========================================================================================! +! This sub-routine flushes all elements of this array to zero. Legacy from the old ! +! code, when vector operations didn't exist. The only difference between this one and ! +! azero is that the input vector here is integer. ! +!------------------------------------------------------------------------------------------! +subroutine izero(nmax,arr) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: nmax + integer, dimension(nmax), intent(out) :: arr + !----- Local variables. ----------------------------------------------------------------! + integer :: n + !---------------------------------------------------------------------------------------! + + do n=1,nmax + arr(n) = 0 + end do + + return +end subroutine izero +!==========================================================================================! +!==========================================================================================! + + + + + +!==========================================================================================! +!==========================================================================================! +! This sub-routine flushes all elements of this array to one. Legacy from the old ! +! code, when vector operations didn't exist. ! +!------------------------------------------------------------------------------------------! +subroutine aone(nmax,arr) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: nmax + real , dimension(nmax), intent(out) :: arr + !----- Local variables. ----------------------------------------------------------------! + integer :: n + !---------------------------------------------------------------------------------------! + + do n=1,nmax + arr(n) = 1. + end do + + return +end subroutine aone +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! subroutine ae1t0(n1,a,b,c) implicit none integer :: n1 @@ -2243,3 +2207,203 @@ real(kind=8) function eifun8(x) end function eifun8 !==========================================================================================! !==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +! This subroutine extracts a vertical (z) column given a 3-D array, and the fixed ! +! indices for the x and y dimensions. ! +!------------------------------------------------------------------------------------------! +subroutine array2zcol(mz,mx,my,x,y,array,vector) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: mz + integer , intent(in) :: mx + integer , intent(in) :: my + integer , intent(in) :: x + integer , intent(in) :: y + real(kind=4), dimension(mz,mx,my), intent(in) :: array + real(kind=4), dimension(mz) , intent(out) :: vector + !----- Local variables. ----------------------------------------------------------------! + integer :: z + !---------------------------------------------------------------------------------------! + + do z=1,mz + vector(z) = array(z,x,y) + end do + + return +end subroutine array2zcol +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +! This subroutine extracts a longitudinal (x) column given a 3-D array, and the fixed ! +! indices for the z and y dimensions. ! +!------------------------------------------------------------------------------------------! +subroutine array2xcol(mz,mx,my,z,y,array,vector) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: mz + integer , intent(in) :: mx + integer , intent(in) :: my + integer , intent(in) :: z + integer , intent(in) :: y + real(kind=4), dimension(mz,mx,my), intent(in) :: array + real(kind=4), dimension(mx) , intent(out) :: vector + !----- Local variables. ----------------------------------------------------------------! + integer :: x + !---------------------------------------------------------------------------------------! + + do x=1,mx + vector(x) = array(z,x,y) + end do + + return +end subroutine array2xcol +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +! This subroutine extracts a latitudinal (y) column given a 3-D array, and the fixed ! +! indices for the z and x dimensions. ! +!------------------------------------------------------------------------------------------! +subroutine array2ycol(mz,mx,my,z,x,array,vector) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: mz + integer , intent(in) :: mx + integer , intent(in) :: my + integer , intent(in) :: z + integer , intent(in) :: x + real(kind=4), dimension(mz,mx,my), intent(in) :: array + real(kind=4), dimension(my) , intent(out) :: vector + !----- Local variables. ----------------------------------------------------------------! + integer :: y + !---------------------------------------------------------------------------------------! + + do y=1,my + vector(y) = array(z,x,y) + end do + + return +end subroutine array2ycol +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +! This subroutine copies a vertical (z) column to a 3-D array, using fixed indices for ! +! the x and y dimensions. ! +!------------------------------------------------------------------------------------------! +subroutine zcol2array(mz,mx,my,x,y,vector,array) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: mz + integer , intent(in) :: mx + integer , intent(in) :: my + integer , intent(in) :: x + integer , intent(in) :: y + real(kind=4), dimension(mz) , intent(in) :: vector + real(kind=4), dimension(mz,mx,my), intent(inout) :: array + !----- Local variables. ----------------------------------------------------------------! + integer :: z + !---------------------------------------------------------------------------------------! + + do z=1,mz + array(z,x,y) = vector(z) + end do + + return +end subroutine zcol2array +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +! This subroutine copies a longitudinal (x) column to a 3-D array, using fixed indices ! +! for the z and y dimensions. ! +!------------------------------------------------------------------------------------------! +subroutine xcol2array(mz,mx,my,z,y,vector,array) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: mz + integer , intent(in) :: mx + integer , intent(in) :: my + integer , intent(in) :: z + integer , intent(in) :: y + real(kind=4), dimension(mx) , intent(in) :: vector + real(kind=4), dimension(mz,mx,my), intent(inout) :: array + !----- Local variables. ----------------------------------------------------------------! + integer :: x + !---------------------------------------------------------------------------------------! + + do x=1,mx + array(z,x,y) = vector(x) + end do + + return +end subroutine xcol2array +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +! This subroutine copies a latitudinal (y) column to a 3-D array, using fixed indices ! +! for the z and x dimensions. ! +!------------------------------------------------------------------------------------------! +subroutine ycol2array(mz,mx,my,z,x,vector,array) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: mz + integer , intent(in) :: mx + integer , intent(in) :: my + integer , intent(in) :: z + integer , intent(in) :: x + real(kind=4), dimension(my) , intent(in) :: vector + real(kind=4), dimension(mz,mx,my), intent(inout) :: array + !----- Local variables. ----------------------------------------------------------------! + integer :: y + !---------------------------------------------------------------------------------------! + + do y=1,my + array(z,x,y) = vector(y) + end do + + return +end subroutine ycol2array +!==========================================================================================! +!==========================================================================================! + + diff --git a/ED/src/utils/stable_cohorts.f90 b/ED/src/utils/stable_cohorts.f90 index 8cf94baf2..44e2822e3 100644 --- a/ED/src/utils/stable_cohorts.f90 +++ b/ED/src/utils/stable_cohorts.f90 @@ -70,7 +70,7 @@ subroutine is_resolvable(csite,ipa,ico,green_leaf_factor) use ed_state_vars , only : sitetype & ! structure , patchtype ! ! structure use phenology_coms, only : elongf_min ! ! intent(in) - use pft_coms , only : lai_min ! ! intent(in) + use pft_coms , only : veg_hcap_min ! ! intent(in) use ed_max_dims , only : n_pft ! ! intent(in) implicit none @@ -103,12 +103,12 @@ subroutine is_resolvable(csite,ipa,ico,green_leaf_factor) !---------------------------------------------------------------------------------------! - ! 2. Check whether this cohort is not extremely sparse. Wood area index is always ! - ! set to zero when branch thermodynamics is turned off, so this will always be ! - ! false in this case. ! + ! 2. Check whether this cohort is not extremely sparse. Wood area heat capacity is ! + ! always set to zero when branch thermodynamics is turned off, so this will always ! + ! be .false. in this case. ! !---------------------------------------------------------------------------------------! - leaf_enough = cpatch%lai(ico) > lai_min(ipft) .and. cpatch%leaf_hcap(ico) > 0.0 - wood_enough = cpatch%wai(ico) > lai_min(ipft) .and. cpatch%wood_hcap(ico) > 0.0 + leaf_enough = cpatch%leaf_hcap(ico) > veg_hcap_min(ipft) + wood_enough = cpatch%wood_hcap(ico) > veg_hcap_min(ipft) !---------------------------------------------------------------------------------------! diff --git a/ED/src/utils/therm_lib.f90 b/ED/src/utils/therm_lib.f90 index 864e93264..d77cc1396 100644 --- a/ED/src/utils/therm_lib.f90 +++ b/ED/src/utils/therm_lib.f90 @@ -14,26 +14,32 @@ module therm_lib !---------------------------------------------------------------------------------------! ! Constants that control the convergence for iterative methods ! !---------------------------------------------------------------------------------------! - real , parameter :: toler = 10.* epsilon(1.) ! Relative tolerance for iterative - ! methods. The smaller the value, the - ! more accurate the result, but it - ! will slow down the run. - integer, parameter :: maxfpo = 60 ! Maximum # of iterations before crash- - ! ing for false position method. - - integer, parameter :: maxit = 150 ! Maximum # of iterations before crash- - ! ing, for other methods. + real(kind=4), parameter :: toler = 10.* epsilon(1.) ! Relative tolerance for iter- + ! ative methods. The smaller + ! the value, the more accurate + ! the result, but smaller + ! values will slow down the + ! run. + integer , parameter :: maxfpo = 60 ! Maximum # of iterations before + ! crashing for false position + ! method. + integer , parameter :: maxit = 150 ! Maximum # of iterations before + ! crashing, for other methods. + integer , parameter :: maxlev = 16 ! Maximum # of levels for adap- + ! tive quadrature methods. + logical , parameter :: newthermo = .true. ! Use new thermodynamics [T|F] + !---------------------------------------------------------------------------------------! - integer, parameter :: maxlev = 16 ! Maximum # of levels for adaptive - ! quadrature methods. - logical, parameter :: newthermo = .true. ! Use new thermodynamics [T|F] !---------------------------------------------------------------------------------------! ! This is the "level" variable, that used to be in micphys. Since it affects more the ! ! thermodynamics choices than the microphysics, it was moved to here. ! !---------------------------------------------------------------------------------------! integer, parameter :: level = 3 + !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! ! The following three variables are just the logical tests on variable "level", ! @@ -56,13 +62,16 @@ module therm_lib ! These equations give the triple point at t3ple, with vapour pressure being es3ple. ! !---------------------------------------------------------------------------------------! !----- Coefficients based on equation (7): ---------------------------------------------! - real, dimension(0:3), parameter :: iii_7 = (/ 9.550426,-5723.265, 3.53068,-0.00728332 /) + real(kind=4), dimension(0:3), parameter :: iii_7 = (/ 9.550426, -5723.265 & + , 3.530680, -0.00728332 /) !----- Coefficients based on equation (10), first fit ----------------------------------! - real, dimension(0:3), parameter :: l01_10= (/54.842763,-6763.22 ,-4.210 , 0.000367 /) + real(kind=4), dimension(0:3), parameter :: l01_10 = (/ 54.842763, -6763.220 & + , -4.210 , 0.000367 /) !----- Coefficients based on equation (10), second fit ---------------------------------! - real, dimension(0:3), parameter :: l02_10= (/53.878 ,-1331.22 ,-9.44523, 0.014025 /) + real(kind=4), dimension(0:3), parameter :: l02_10 = (/ 53.878 , -1331.22 & + , -9.44523 , 0.014025 /) !----- Coefficients based on the hyperbolic tangent ------------------------------------! - real, dimension(2) , parameter :: ttt_10= (/0.0415,218.8/) + real(kind=4), dimension(2) , parameter :: ttt_10 = (/ 0.0415 , 218.80 /) !---------------------------------------------------------------------------------------! @@ -79,44 +88,70 @@ module therm_lib ! what was on the original code... ! !---------------------------------------------------------------------------------------! !----- Coefficients for esat (liquid) --------------------------------------------------! - real, dimension(0:8), parameter :: cll = (/ .6105851e+03, .4440316e+02, .1430341e+01 & - , .2641412e-01, .2995057e-03, .2031998e-05 & - , .6936113e-08, .2564861e-11, -.3704404e-13 /) + real(kind=4), dimension(0:8), parameter :: cll = (/ .6105851e+03, .4440316e+02 & + , .1430341e+01, .2641412e-01 & + , .2995057e-03, .2031998e-05 & + , .6936113e-08, .2564861e-11 & + , -.3704404e-13 /) !----- Coefficients for esat (ice) -----------------------------------------------------! - real, dimension(0:8), parameter :: cii = (/ .6114327e+03, .5027041e+02, .1875982e+01 & - , .4158303e-01, .5992408e-03, .5743775e-05 & - , .3566847e-07, .1306802e-09, .2152144e-12 /) + real(kind=4), dimension(0:8), parameter :: cii = (/ .6114327e+03, .5027041e+02 & + , .1875982e+01, .4158303e-01 & + , .5992408e-03, .5743775e-05 & + , .3566847e-07, .1306802e-09 & + , .2152144e-12 /) !----- Coefficients for d(esat)/dT (liquid) --------------------------------------------! - real, dimension(0:8), parameter :: dll = (/ .4443216e+02, .2861503e+01, .7943347e-01 & - , .1209650e-02, .1036937e-04, .4058663e-07 & - ,-.5805342e-10, -.1159088e-11, -.3189651e-14 /) + real(kind=4), dimension(0:8), parameter :: dll = (/ .4443216e+02, .2861503e+01 & + , .7943347e-01, .1209650e-02 & + , .1036937e-04, .4058663e-07 & + , -.5805342e-10, -.1159088e-11 & + , -.3189651e-14 /) !----- Coefficients for esat (ice) -----------------------------------------------------! - real, dimension(0:8), parameter :: dii = (/ .5036342e+02, .3775758e+01, .1269736e+00 & - , .2503052e-02, .3163761e-04, .2623881e-06 & - , .1392546e-08, .4315126e-11, .5961476e-14 /) - !---------------------------------------------------------------------------------------! - + real(kind=4), dimension(0:8), parameter :: dii = (/ .5036342e+02, .3775758e+01 & + , .1269736e+00, .2503052e-02 & + , .3163761e-04, .2623881e-06 & + , .1392546e-08, .4315126e-11 & + , .5961476e-14 /) + !=======================================================================================! + !=======================================================================================! contains + + + !=======================================================================================! !=======================================================================================! ! This function calculates the liquid saturation vapour pressure as a function of ! ! Kelvin temperature. This expression came from MK05, equation (10). ! !---------------------------------------------------------------------------------------! - real function eslf(temp,l1funout,l2funout,ttfunout) - use consts_coms, only : t00 + real(kind=4) function eslf(temp,l1funout,l2funout,ttfunout) + use consts_coms, only : t00 ! ! intent(in) implicit none - real, intent(in) :: temp - real, intent(out), optional :: l1funout,ttfunout,l2funout - real :: l1fun,ttfun,l2fun,x + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! + real(kind=4), intent(out), optional :: l1funout ! Function for high temperatures + real(kind=4), intent(out), optional :: ttfunout ! Interpolation function + real(kind=4), intent(out), optional :: l2funout ! Function for low temperatures + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: l1fun ! + real(kind=4) :: ttfun ! + real(kind=4) :: l2fun ! + real(kind=4) :: x ! + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Choose between the old and the new thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then !----- Updated method, using MK05 ------------------------------------------------! l1fun = l01_10(0) + l01_10(1)/temp + l01_10(2)*log(temp) + l01_10(3) * temp l2fun = l02_10(0) + l02_10(1)/temp + l02_10(2)*log(temp) + l02_10(3) * temp ttfun = tanh(ttt_10(1) * (temp - ttt_10(2))) eslf = exp(l1fun + ttfun*l2fun) + !---------------------------------------------------------------------------------! if (present(l1funout)) l1funout = l1fun if (present(l2funout)) l2funout = l2fun @@ -126,6 +161,7 @@ real function eslf(temp,l1funout,l2funout,ttfunout) x = max(-80.,temp-t00) eslf = cll(0) + x * (cll(1) + x * (cll(2) + x * (cll(3) + x * (cll(4) & + x * (cll(5) + x * (cll(6) + x * (cll(7) + x * cll(8)) ) ) ) ) ) ) + !---------------------------------------------------------------------------------! if (present(l1funout)) l1funout = eslf if (present(l2funout)) l2funout = eslf @@ -147,28 +183,42 @@ end function eslf ! This function calculates the ice saturation vapour pressure as a function of ! ! Kelvin temperature, based on MK05 equation (7). ! !---------------------------------------------------------------------------------------! - real function esif(temp,iifunout) - use consts_coms, only : t00 + real(kind=4) function esif(temp,iifunout) + use consts_coms, only : t00 ! ! intent(in) implicit none - real, intent(in) :: temp - real, intent(out), optional :: iifunout - real :: iifun,x + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! + real(kind=4), intent(out), optional :: iifunout + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: iifun + real(kind=4) :: x + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Choose between the old and the new thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then !----- Updated method, using MK05 ------------------------------------------------! iifun = iii_7(0) + iii_7(1)/temp + iii_7(2) * log(temp) + iii_7(3) * temp esif = exp(iifun) - + !---------------------------------------------------------------------------------! + + if (present(iifunout)) iifunout=iifun else !----- Original method, using polynomial fit (FWC92) -----------------------------! x=max(-80.,temp-t00) esif = cii(0) + x * (cii(1) + x * (cii(2) + x * (cii(3) + x * (cii(4) & + x * (cii(5) + x * (cii(6) + x * (cii(7) + x * cii(8)) ) ) ) ) ) ) + !---------------------------------------------------------------------------------! if (present(iifunout)) iifunout=esif end if + !------------------------------------------------------------------------------------! + return end function esif !=======================================================================================! @@ -185,24 +235,44 @@ end function esif ! temperature. It chooses which phase to look depending on whether the temperature is ! ! below or above the triple point. ! !---------------------------------------------------------------------------------------! - real function eslif(temp,useice) - use consts_coms, only: t3ple + real(kind=4) function eslif(temp,useice) + use consts_coms, only : t3ple ! ! intent(in) implicit none - real , intent(in) :: temp - logical, intent(in), optional :: useice - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice + !----- Local variables. -------------------------------------------------------------! + logical :: frozen + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple end if + !------------------------------------------------------------------------------------! + + - if (brrr_cold) then - eslif = esif(temp) ! Ice saturation vapour pressure + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- Saturation vapour pressure for ice. ---------------------------------------! + eslif = esif(temp) + !---------------------------------------------------------------------------------! else - eslif = eslf(temp) ! Liquid saturation vapour pressure + !----- Saturation vapour pressure for liquid. ------------------------------------! + eslif = eslf(temp) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return end function eslif @@ -219,14 +289,29 @@ end function eslif ! This function calculates the liquid saturation vapour mixing ratio as a function ! ! of pressure and Kelvin temperature. ! !---------------------------------------------------------------------------------------! - real function rslf(pres,temp) - use consts_coms, only : ep,toodry + real(kind=4) function rslf(pres,temp) + use consts_coms, only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real, intent(in) :: pres,temp - real :: esl + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esl ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + !----- First we find the saturation vapour pressure. --------------------------------! esl = eslf(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the mixing ! + ! ratio. ! + !------------------------------------------------------------------------------------! rslf = max(toodry,ep*esl/(pres-esl)) + !------------------------------------------------------------------------------------! return end function rslf @@ -243,14 +328,29 @@ end function rslf ! This function calculates the ice saturation vapour mixing ratio as a function of ! ! pressure and Kelvin temperature. ! !---------------------------------------------------------------------------------------! - real function rsif(pres,temp) - use consts_coms, only : ep,toodry + real(kind=4) function rsif(pres,temp) + use consts_coms, only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real, intent(in) :: pres,temp - real :: esi + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esi ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + !----- First we find the saturation vapour pressure. --------------------------------! esi = esif(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the mixing ! + ! ratio. ! + !------------------------------------------------------------------------------------! rsif = max(toodry,ep*esi/(pres-esi)) + !------------------------------------------------------------------------------------! return end function rsif @@ -267,29 +367,55 @@ end function rsif ! This function calculates the saturation vapour mixing ratio, over liquid or ice ! ! depending on temperature, as a function of pressure and Kelvin temperature. ! !---------------------------------------------------------------------------------------! - real function rslif(pres,temp,useice) - use consts_coms, only: t3ple,ep + real(kind=4) function rslif(pres,temp,useice) + use consts_coms, only : t3ple & ! intent(in) + , ep ! ! intent(in) implicit none - real , intent(in) :: pres,temp - logical, intent(in), optional :: useice - real :: esz - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: pres + real(kind=4), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esz + logical :: frozen + !------------------------------------------------------------------------------------! + - !----- Checking which saturation (liquid or ice) I should use here ------------------! + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple end if + !------------------------------------------------------------------------------------! - !----- Finding the saturation vapour pressure ---------------------------------------! - if (brrr_cold) then + + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- Saturation vapour pressure for ice. ---------------------------------------! esz = esif(temp) + !---------------------------------------------------------------------------------! else + !----- Saturation vapour pressure for liquid. ------------------------------------! esz = eslf(temp) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the mixing ! + ! ratio. ! + !------------------------------------------------------------------------------------! rslif = ep * esz / (pres - esz) + !------------------------------------------------------------------------------------! return end function rslif @@ -301,19 +427,179 @@ end function rslif + !=======================================================================================! + !=======================================================================================! + ! This function calculates the liquid saturation specific humidity as a function of ! + ! pressure and Kelvin temperature. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function qslf(pres,temp) + use consts_coms, only : ep & ! intent(in) + , toodry ! ! intent(in) + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esl ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- First we find the saturation vapour pressure. --------------------------------! + esl = eslf(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the ! + ! specific humidity. ! + !------------------------------------------------------------------------------------! + qslf = max(toodry,ep * esl/( pres - (1.0 - ep) * esl) ) + !------------------------------------------------------------------------------------! + + return + end function qslf + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function calculates the ice saturation specific humidity as a function of ! + ! pressure and Kelvin temperature. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function qsif(pres,temp) + use consts_coms, only : ep & ! intent(in) + , toodry ! ! intent(in) + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esi ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- First we find the saturation vapour pressure. --------------------------------! + esi = esif(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the ! + ! specific humidity. ! + !------------------------------------------------------------------------------------! + qsif = max(toodry,ep * esi/( pres - (1.0 - ep) * esi) ) + !------------------------------------------------------------------------------------! + + return + end function qsif + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function calculates the saturation specific humidity, over liquid or ice ! + ! depending on temperature, as a function of pressure and Kelvin temperature. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function qslif(pres,temp,useice) + use consts_coms, only : t3ple & ! intent(in) + , ep & ! intent(in) + , toodry ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: pres + real(kind=4), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esz + logical :: frozen + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! + if (present(useice)) then + frozen = useice .and. temp < t3ple + else + frozen = bulk_on .and. temp < t3ple + end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- Saturation vapour pressure for ice. ---------------------------------------! + esz = esif(temp) + !---------------------------------------------------------------------------------! + else + !----- Saturation vapour pressure for liquid. ------------------------------------! + esz = eslf(temp) + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the ! + ! specific humidity. ! + !------------------------------------------------------------------------------------! + qslif = max(toodry, ep * esz/( pres - (1.0 - ep) * esz) ) + !------------------------------------------------------------------------------------! + + return + end function qslif + !=======================================================================================! + !=======================================================================================! + + + + + + !=======================================================================================! !=======================================================================================! ! This function calculates the vapour-liquid equilibrium density for vapour, as a ! ! function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! - real function rhovsl(temp) - use consts_coms, only : rh2o + real(kind=4) function rhovsl(temp) + use consts_coms, only : rh2o ! ! intent(in) implicit none - real, intent(in) :: temp - real :: eequ + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: eequ ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the equilibrium (saturation) vapour pressure. ! + !------------------------------------------------------------------------------------! eequ = eslf(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the saturation density. ! + !------------------------------------------------------------------------------------! rhovsl = eequ / (rh2o * temp) + !------------------------------------------------------------------------------------! + return end function rhovsl !=======================================================================================! @@ -330,13 +616,29 @@ end function rhovsl ! This function calculates the vapour-ice equilibrium density for vapour, as a ! ! function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! - real function rhovsi(temp) - use consts_coms, only : rh2o + real(kind=4) function rhovsi(temp) + use consts_coms, only : rh2o ! ! intent(in) implicit none - real, intent(in) :: temp - real :: eequ + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: eequ ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the equilibrium (saturation) vapour pressure. ! + !------------------------------------------------------------------------------------! eequ = esif(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the saturation density. ! + !------------------------------------------------------------------------------------! rhovsi = eequ / (rh2o * temp) + !------------------------------------------------------------------------------------! + return end function rhovsi !=======================================================================================! @@ -347,27 +649,42 @@ end function rhovsi - !=======================================================================================! !=======================================================================================! ! This function calculates the saturation density for vapour, as a function of tem- ! ! perature in Kelvin. It will decide between ice-vapour or liquid-vapour based on the ! ! temperature. ! !---------------------------------------------------------------------------------------! - real function rhovsil(temp,useice) - use consts_coms, only : rh2o + real(kind=4) function rhovsil(temp,useice) + use consts_coms, only : rh2o ! ! intent(in) implicit none - real, intent(in) :: temp - logical, intent(in), optional :: useice - real :: eequ + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: eequ + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Pass the "useice" argument to eslif, so it may decide whether ice thermo- ! + ! dynamics is to be used. ! + !------------------------------------------------------------------------------------! if (present(useice)) then eequ = eslif(temp,useice) else eequ = eslif(temp) end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the saturation density. ! + !------------------------------------------------------------------------------------! rhovsil = eequ / (rh2o * temp) + !------------------------------------------------------------------------------------! return end function rhovsil @@ -384,25 +701,40 @@ end function rhovsil ! This function calculates the partial derivative of liquid saturation vapour ! ! pressure with respect to temperature as a function of Kelvin temperature. ! !---------------------------------------------------------------------------------------! - real function eslfp(temp) - use consts_coms, only: t00 + real(kind=4) function eslfp(temp) + use consts_coms, only : t00 ! ! intent(in) implicit none - real, intent(in) :: temp - real :: esl,l2fun,ttfun,l1prime,l2prime,ttprime,x + !------ Arguments. ------------------------------------------------------------------! + real(kind=4), intent(in) :: temp + !------ Local variables. ------------------------------------------------------------! + real(kind=4) :: esl + real(kind=4) :: l2fun + real(kind=4) :: ttfun + real(kind=4) :: l1prime + real(kind=4) :: l2prime + real(kind=4) :: ttprime + real(kind=4) :: x + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide which function to use, based on the thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then !----- Updated method, using MK05 ------------------------------------------------! - esl = eslf(temp,l2funout=l2fun,ttfunout=ttfun) + esl = eslf(temp,l2funout=l2fun,ttfunout=ttfun) l1prime = -l01_10(1)/(temp*temp) + l01_10(2)/temp + l01_10(3) l2prime = -l02_10(1)/(temp*temp) + l02_10(2)/temp + l02_10(3) ttprime = ttt_10(1)*(1.-ttfun*ttfun) - eslfp = esl * (l1prime + l2prime*ttfun + l2fun*ttprime) + eslfp = esl * (l1prime + l2prime*ttfun + l2fun*ttprime) else !----- Original method, using polynomial fit (FWC92) -----------------------------! - x=max(-80.,temp-t00) + x = max(-80.,temp-t00) eslfp = dll(0) + x * (dll(1) + x * (dll(2) + x * (dll(3) + x * (dll(4) & + x * (dll(5) + x * (dll(6) + x * (dll(7) + x * dll(8)) ) ) ) ) ) ) end if + !------------------------------------------------------------------------------------! return @@ -420,12 +752,22 @@ end function eslfp ! This function calculates the partial derivative of ice saturation vapour pressure ! ! with respect to temperature as a function of Kelvin temperature. ! !---------------------------------------------------------------------------------------! - real function esifp(temp) - use consts_coms, only: t00 + real(kind=4) function esifp(temp) + use consts_coms, only : t00 ! ! intent(in) implicit none - real, intent(in) :: temp - real :: esi,iiprime,x + !------ Arguments. ------------------------------------------------------------------! + real(kind=4), intent(in) :: temp + !------ Local variables. ------------------------------------------------------------! + real(kind=4) :: esi + real(kind=4) :: iiprime + real(kind=4) :: x + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide which function to use, based on the thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then !----- Updated method, using MK05 ------------------------------------------------! esi = esif(temp) @@ -437,6 +779,7 @@ real function esifp(temp) esifp = dii(0) + x * (dii(1) + x * (dii(2) + x * (dii(3) + x * (dii(4) & + x * (dii(5) + x * (dii(6) + x * (dii(7) + x * dii(8)) ) ) ) ) ) ) end if + !------------------------------------------------------------------------------------! return end function esifp @@ -454,24 +797,44 @@ end function esifp ! a function of Kelvin temperature. It chooses which phase to look depending on ! ! whether the temperature is below or above the triple point. ! !---------------------------------------------------------------------------------------! - real function eslifp(temp,useice) - use consts_coms, only: t3ple + real(kind=4) function eslifp(temp,useice) + use consts_coms, only : t3ple ! ! intent(in) implicit none - real , intent(in) :: temp - logical, intent(in), optional :: useice - logical :: brrr_cold + !------ Arguments. ------------------------------------------------------------------! + real(kind=4), intent(in) :: temp + !------ Local variables. ------------------------------------------------------------! + logical , intent(in), optional :: useice + logical :: frozen + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple end if + !------------------------------------------------------------------------------------! + - if (brrr_cold) then - eslifp = esifp(temp) ! d(Ice saturation vapour pressure)/dT + + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- d(Saturation vapour pressure)/dT for ice. ---------------------------------! + eslifp = esifp(temp) + !---------------------------------------------------------------------------------! else - eslifp = eslfp(temp) ! d(Liquid saturation vapour pressure)/dT + !----- d(Saturation vapour pressure)/dT for liquid water. ------------------------! + eslifp = eslfp(temp) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return end function eslifp @@ -490,17 +853,37 @@ end function eslifp ! ing ratio with respect to temperature as a function of pressure and Kelvin tempera- ! ! ture. ! !---------------------------------------------------------------------------------------! - real function rslfp(pres,temp) - use consts_coms, only: ep + real(kind=4) function rslfp(pres,temp) + use consts_coms, only : ep ! ! intent(in) implicit none - real, intent(in) :: pres,temp - real :: desdt,esl,pdry + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esl ! Partial pressure [ Pa] + real(kind=4) :: desdt ! Derivative of partial pressure of water [ Pa/K] + real(kind=4) :: pdry ! Partial pressure of dry air [ Pa] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! esl = eslf(temp) desdt = eslfp(temp) - + !------------------------------------------------------------------------------------! + + + !----- Find the partial pressure of dry air. ----------------------------------------! pdry = pres-esl + !------------------------------------------------------------------------------------! + + + !----- Find the partial derivative of mixing ratio. ---------------------------------! rslfp = ep * pres * desdt / (pdry*pdry) + !------------------------------------------------------------------------------------! return end function rslfp @@ -519,18 +902,36 @@ end function rslfp ! ing ratio with respect to temperature as a function of pressure and Kelvin tempera- ! ! ture. ! !---------------------------------------------------------------------------------------! - real function rsifp(pres,temp) - use consts_coms, only: ep + real(kind=4) function rsifp(pres,temp) + use consts_coms, only : ep ! ! intent(in) implicit none - real, intent(in) :: pres,temp - real :: desdt,esi,pdry + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esi ! Partial pressure [ Pa] + real(kind=4) :: desdt ! Derivative of partial pressure of water [ Pa/K] + real(kind=4) :: pdry ! Partial pressure of dry air [ Pa] + !------------------------------------------------------------------------------------! - esi = esif(temp) - desdt = esifp(temp) - + + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! + esi = esif(temp) + desdt = esifp(temp) + !------------------------------------------------------------------------------------! + + + !----- Find the partial pressure of dry air. ----------------------------------------! pdry = pres-esi - rsifp = ep * pres * desdt / (pdry*pdry) + !------------------------------------------------------------------------------------! + + !----- Find the partial derivative of mixing ratio. ---------------------------------! + rsifp = ep * pres * desdt / (pdry*pdry) + !------------------------------------------------------------------------------------! return end function rsifp !=======================================================================================! @@ -548,25 +949,42 @@ end function rsifp ! ing ratio with respect to temperature as a function of pressure and Kelvin tempera- ! ! ture. ! !---------------------------------------------------------------------------------------! - real function rslifp(pres,temp,useice) - use consts_coms, only: t3ple + real(kind=4) function rslifp(pres,temp,useice) + use consts_coms, only: t3ple ! ! intent(in) implicit none - real , intent(in) :: pres,temp - logical, intent(in), optional :: useice - real :: desdt - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics? [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: desdt ! Derivative of vapour pressure [ Pa/K] + logical :: frozen ! Use the ice thermodynamics [ T|F] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide whether to use liquid water of ice for saturation, based on the temper- ! + ! ature and the settings. ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple end if + !------------------------------------------------------------------------------------! + - if (brrr_cold) then - rslifp=rsifp(pres,temp) + !------------------------------------------------------------------------------------! + ! Call the function depending on the previous check. ! + !------------------------------------------------------------------------------------! + if (frozen) then + rslifp = rsifp(pres,temp) else - rslifp=rslfp(pres,temp) + rslifp = rslfp(pres,temp) end if + !------------------------------------------------------------------------------------! return end function rslifp @@ -584,15 +1002,30 @@ end function rslifp ! This function calculates the derivative of vapour-liquid equilibrium density, as ! ! a function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! - real function rhovslp(temp) - use consts_coms, only : rh2o + real(kind=4) function rhovslp(temp) + use consts_coms, only : rh2o ! ! intent(in) implicit none - real, intent(in) :: temp - real :: es,desdt + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: es ! Vapour pressure [ Pa] + real(kind=4) :: desdt ! Vapour pressure derivative [ Pa/K] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! es = eslf(temp) desdt = eslfp(temp) + !------------------------------------------------------------------------------------! + + + !----- Find the partial derivative of saturation density . --------------------------! rhovslp = (desdt-es/temp) / (rh2o * temp) + !------------------------------------------------------------------------------------! return end function rhovslp @@ -610,15 +1043,30 @@ end function rhovslp ! This function calculates the derivative of vapour-ice equilibrium density, as a ! ! function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! - real function rhovsip(temp) - use consts_coms, only : rh2o + real(kind=4) function rhovsip(temp) + use consts_coms, only : rh2o ! ! intent(in) implicit none - real, intent(in) :: temp - real :: es,desdt + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: es ! Vapour pressure [ Pa] + real(kind=4) :: desdt ! Vapour pressure derivative [ Pa/K] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! es = esif(temp) desdt = esifp(temp) + !------------------------------------------------------------------------------------! + + + !----- Find the partial derivative of saturation density . --------------------------! rhovsip = (desdt-es/temp) / (rh2o * temp) + !------------------------------------------------------------------------------------! return end function rhovsip @@ -637,24 +1085,40 @@ end function rhovsip ! function of temperature in Kelvin. It will decide between ice-vapour or liquid-vapour ! ! based on the temperature. ! !---------------------------------------------------------------------------------------! - real function rhovsilp(temp,useice) - use consts_coms, only: t3ple + real(kind=4) function rhovsilp(temp,useice) + use consts_coms, only : t3ple ! ! intent(in) implicit none - real, intent(in) :: temp - logical, intent(in), optional :: useice - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics? [ T|F] + !----- Local variables. -------------------------------------------------------------! + logical :: frozen ! Derivative of vapour pressure [ Pa/K] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide whether to use liquid water of ice for saturation, based on the temper- ! + ! ature and the settings. ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple end if + !------------------------------------------------------------------------------------! - if (brrr_cold) then - rhovsilp=rhovsip(temp) + + !------------------------------------------------------------------------------------! + ! Call the function depending on the previous check. ! + !------------------------------------------------------------------------------------! + if (frozen) then + rhovsilp = rhovsip(temp) else - rhovsilp=rhovslp(temp) + rhovsilp = rhovslp(temp) end if + !------------------------------------------------------------------------------------! return end function rhovsilp @@ -675,67 +1139,95 @@ end function rhovsilp ! the unlikely case in which Newton's method fails, switch back to modified Regula ! ! Falsi method (Illinois). ! !---------------------------------------------------------------------------------------! - real function tslf(pvap) + real(kind=4) function tslf(pvap) - implicit none - !----- Argument ---------------------------------------------------------------------! - real, intent(in) :: pvap ! Saturation vapour pressure [ Pa] - !----- Local variables for iterative method -----------------------------------------! - real :: deriv ! Function derivative [ Pa] - real :: fun ! Function for which we seek a root. [ Pa] - real :: funa ! Smallest guess function [ Pa] - real :: funz ! Largest guess function [ Pa] - real :: tempa ! Smallest guess (or previous guess) [ Pa] - real :: tempz ! Largest guess (or new guess in Newton) [ Pa] - real :: delta ! Aux. var --- 2nd guess for bisection [ ] - integer :: itn,itb ! Iteration counter [ ---] - logical :: converged ! Convergence handle [ ---] - logical :: zside ! Flag to check for one-sided approach... [ ---] - !------------------------------------------------------------------------------------! - - !----- First Guess, using Bolton (1980) equation 11, giving es in Pa and T in K -----! + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pvap ! Saturation vapour pressure [ Pa] + !----- Local variables for iterative method. ----------------------------------------! + real(kind=4) :: deriv ! Function derivative [ Pa] + real(kind=4) :: fun ! Function for which we seek a root. [ Pa] + real(kind=4) :: funa ! Smallest guess function [ Pa] + real(kind=4) :: funz ! Largest guess function [ Pa] + real(kind=4) :: tempa ! Smallest guess (or previous guess) [ Pa] + real(kind=4) :: tempz ! Largest guess (new guess in Newton) [ Pa] + real(kind=4) :: delta ! Aux. var --- 2nd guess for bisection [ ] + integer :: itn ! Iteration counter [ ---] + integer :: itb ! Iteration counter [ ---] + logical :: converged ! Convergence handle [ ---] + logical :: zside ! Flag to check for one-sided approach [ ---] + !------------------------------------------------------------------------------------! + + !----- First Guess, use Bolton (1980) equation 11, giving es in Pa and T in K -------! tempa = (29.65 * log(pvap) - 5016.78)/(log(pvap)-24.0854) funa = eslf(tempa) - pvap deriv = eslfp(tempa) - !----- Copying just in case it fails at the first iteration -------------------------! + !------------------------------------------------------------------------------------! + + + !----- Copy just in case it fails at the first iteration ----------------------------! tempz = tempa fun = funa - + !------------------------------------------------------------------------------------! + + !----- Enter Newton's method loop: --------------------------------------------------! converged = .false. newloop: do itn = 1,maxfpo/6 if (abs(deriv) < toler) exit newloop !----- Too dangerous, go with bisection -----! - !----- Copying the previous guess ------------------------------------------------! + + !----- Copy the previous guess. --------------------------------------------------! tempa = tempz funa = fun - !----- New guess, its function and derivative evaluation -------------------------! + !---------------------------------------------------------------------------------! + + + !----- New guess, its function, and derivative evaluation. -----------------------! tempz = tempa - fun/deriv fun = eslf(tempz) - pvap deriv = eslfp(tempz) - + !---------------------------------------------------------------------------------! + + + !----- Check convergence. --------------------------------------------------------! converged = abs(tempa-tempz) < toler * tempz if (converged) then - tslf = 0.5*(tempa+tempz) + tslf = 0.5 * (tempa+tempz) return - elseif (fun ==0) then !Converged by luck! + elseif (fun == 0.0) then + !----- Converged by luck. -----------------------------------------------------! tslf = tempz return end if + !---------------------------------------------------------------------------------! end do newloop + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! If we have reached this point, then Newton's method has failed. Use bisection ! + ! instead. For bisection, we need two guesses whose function has opposite signs. ! !------------------------------------------------------------------------------------! if (funa * fun < 0.) then + !----- We already have two guesses with opposite signs. --------------------------! funz = fun zside = .true. + !---------------------------------------------------------------------------------! else + !----- Need to find the guesses with opposite signs. -----------------------------! if (abs(fun-funa) < 100.*toler*tempa) then delta = 100.*toler*tempa else delta = max(abs(funa * (tempz-tempa)/(fun-funa)),100.*toler*tempa) end if + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! Try guesses on both sides of the first guess, increasingly further away ! + ! until we spot a good guess. ! + !---------------------------------------------------------------------------------! tempz = tempa + delta zside = .false. zgssloop: do itb=1,maxfpo @@ -745,11 +1237,22 @@ real function tslf(pvap) if (zside) exit zgssloop end do zgssloop if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempa=',tempa,'funa=',funa - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempz=',tempz,'func=',funz + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the second guess:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' call fatal_error('Failed finding the second guess for regula falsi' & - ,'tslf','therm_lib.f90') + ,'tslf','therm_lib.f90') end if end if @@ -758,36 +1261,52 @@ real function tslf(pvap) tslf = (funz*tempa-funa*tempz)/(funz-funa) !---------------------------------------------------------------------------------! - ! Now that we updated the guess, check whether they are really close. If so, ! + ! Now that we updated the guess, check whether they are really close. If so, ! ! it converged, I can use this as my guess. ! !---------------------------------------------------------------------------------! converged = abs(tslf-tempa) < toler * tslf if (converged) exit bisloop - !------ Finding the new function -------------------------------------------------! + !------ Find the new function evaluation. ----------------------------------------! fun = eslf(tslf) - pvap + !---------------------------------------------------------------------------------! - !------ Defining my new interval based on the intermediate value theorem. --------! + + !------ Define the new interval based on the intermediate value theorem. ---------! if (fun*funa < 0. ) then tempz = tslf funz = fun - !----- If we are updating zside again, modify aside (Illinois method) ---------! + !----- If we are updating zside again, modify aside (Illinois method). --------! if (zside) funa=funa * 0.5 - !----- We just updated zside, setting zside to true. --------------------------! + !----- We have just updated zside, so we set zside to true. -------------------! zside = .true. else tempa = tslf funa = fun - !----- If we are updating aside again, modify aside (Illinois method) ---------! + !----- If we are updating aside again, modify zside (Illinois method). --------! if (.not. zside) funz=funz * 0.5 - !----- We just updated aside, setting aside to true. --------------------------! + !----- We have just updated aside, so we set zside to false. ------------------! zside = .false. end if end do bisloop if (.not.converged) then - call fatal_error('Temperature didn''t converge, giving up!!!' & - ,'tslf','therm_lib.f90') + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the solution:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' + call fatal_error('Temperature didn''t converge, we give up!!!' & + ,'tslf','therm_lib.f90') end if return @@ -808,44 +1327,56 @@ end function tslf ! the unlikely case in which Newton's method fails, switch back to modified Regula ! ! Falsi method (Illinois). ! !---------------------------------------------------------------------------------------! - real function tsif(pvap) + real(kind=4) function tsif(pvap) - implicit none - !----- Argument ---------------------------------------------------------------------! - real, intent(in) :: pvap ! Saturation vapour pressure [ Pa] + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pvap ! Saturation vapour pressure [ Pa] !----- Local variables for iterative method -----------------------------------------! - real :: deriv ! Function derivative [ Pa] - real :: fun ! Function for which we seek a root. [ Pa] - real :: funa ! Smallest guess function [ Pa] - real :: funz ! Largest guess function [ Pa] - real :: tempa ! Smallest guess (or previous guess) [ Pa] - real :: tempz ! Largest guess (or new guess in Newton) [ Pa] - real :: delta ! Aux. var --- 2nd guess for bisection [ ] - integer :: itn,itb ! Iteration counter [ ---] - logical :: converged ! Convergence handle [ ---] - logical :: zside ! Flag to check for one-sided approach... [ ---] - !------------------------------------------------------------------------------------! - - !----- First Guess, using Murphy-Koop (2005), equation 8. ---------------------------! + real(kind=4) :: deriv ! Function derivative [ Pa] + real(kind=4) :: fun ! Function for which we seek a root. [ Pa] + real(kind=4) :: funa ! Smallest guess function [ Pa] + real(kind=4) :: funz ! Largest guess function [ Pa] + real(kind=4) :: tempa ! Smallest guess (or previous guess) [ Pa] + real(kind=4) :: tempz ! Largest guess (new guess in Newton) [ Pa] + real(kind=4) :: delta ! Aux. var --- 2nd guess for bisection [ ] + integer :: itn + integer :: itb ! Iteration counter [ ---] + logical :: converged ! Convergence handle [ ---] + logical :: zside ! Flag to check for one-sided approach [ ---] + !------------------------------------------------------------------------------------! + + !----- First Guess, use Murphy-Koop (2005), equation 8. -----------------------------! tempa = (1.814625 * log(pvap) +6190.134)/(29.120 - log(pvap)) funa = esif(tempa) - pvap deriv = esifp(tempa) - !----- Copying just in case it fails at the first iteration -------------------------! + !------------------------------------------------------------------------------------! + + + !----- Copy just in case it fails at the first iteration ----------------------------! tempz = tempa fun = funa - + !------------------------------------------------------------------------------------! + + !----- Enter Newton's method loop: --------------------------------------------------! converged = .false. newloop: do itn = 1,maxfpo/6 if (abs(deriv) < toler) exit newloop !----- Too dangerous, go with bisection -----! - !----- Copying the previous guess ------------------------------------------------! + + !----- Copy the previous guess. --------------------------------------------------! tempa = tempz funa = fun - !----- New guess, its function and derivative evaluation -------------------------! + + + !----- New guess, its function, and derivative evaluation. -----------------------! tempz = tempa - fun/deriv fun = esif(tempz) - pvap deriv = esifp(tempz) - + !---------------------------------------------------------------------------------! + + + !----- Check convergence. --------------------------------------------------------! converged = abs(tempa-tempz) < toler * tempz if (converged) then tsif = 0.5*(tempa+tempz) @@ -855,35 +1386,58 @@ real function tsif(pvap) return end if end do newloop + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! If we have reached this point, then Newton's method has failed. Use bisection ! + ! instead. For bisection, we need two guesses whose function has opposite signs. ! !------------------------------------------------------------------------------------! if (funa * fun < 0.) then + !----- We already have two guesses with opposite signs. --------------------------! funz = fun zside = .true. + !---------------------------------------------------------------------------------! else + !----- Need to find the guesses with opposite signs. -----------------------------! if (abs(fun-funa) < 100.*toler*tempa) then delta = 100.*toler*delta else delta = max(abs(funa * (tempz-tempa)/(fun-funa)),100.*toler*tempa) end if + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! Try guesses on both sides of the first guess, increasingly further away ! + ! until we spot a good guess. ! + !---------------------------------------------------------------------------------! tempz = tempa + delta zside = .false. zgssloop: do itb=1,maxfpo tempz = tempa + real((-1)**itb * (itb+3)/2) * delta funz = esif(tempz) - pvap - zside = funa*funz < 0 + zside = funa*funz < 0.0 if (zside) exit zgssloop end do zgssloop if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(1(a,1x,es14.7))') 'pvap =',pvap - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempa=',tempa,'funa=',funa - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempz=',tempz,'func=',funz + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the second guess:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' call fatal_error('Failed finding the second guess for regula falsi' & - ,'tsif','therm_lib.f90') + ,'tsif','therm_lib.f90') end if end if @@ -892,36 +1446,53 @@ real function tsif(pvap) tsif = (funz*tempa-funa*tempz)/(funz-funa) !---------------------------------------------------------------------------------! - ! Now that we updated the guess, check whether they are really close. If so, ! + ! Now that we updated the guess, check whether they are really close. If so, ! ! it converged, I can use this as my guess. ! !---------------------------------------------------------------------------------! converged = abs(tsif-tempa) < toler * tsif if (converged) exit bisloop + !---------------------------------------------------------------------------------! - !------ Finding the new function -------------------------------------------------! + !------ Find the new function evaluation. ----------------------------------------! fun = esif(tsif) - pvap + !---------------------------------------------------------------------------------! - !------ Defining my new interval based on the intermediate value theorem. --------! + + !------ Define the new interval based on the intermediate value theorem. ---------! if (fun*funa < 0. ) then tempz = tsif funz = fun - !----- If we are updating zside again, modify aside (Illinois method) ---------! + !----- If we are updating zside again, modify aside (Illinois method). --------! if (zside) funa=funa * 0.5 - !----- We just updated zside, setting zside to true. --------------------------! + !----- We have just updated zside, so we set zside to true. -------------------! zside = .true. else tempa = tsif funa = fun - !----- If we are updating aside again, modify aside (Illinois method) ---------! + !----- If we are updating aside again, modify aside (Illinois method). --------! if (.not. zside) funz=funz * 0.5 - !----- We just updated aside, setting aside to true. --------------------------! + !----- We have just updated aside, so we set zside to false. ------------------! zside = .false. end if end do bisloop if (.not.converged) then - call fatal_error('Temperature didn''t converge, giving up!!!' & - ,'tsif','therm_lib.f90') + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the solution:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' + call fatal_error('Temperature didn''t converge, we give up!!!' & + ,'tsif','therm_lib.f90') end if return @@ -939,30 +1510,41 @@ end function tsif ! This function calculates the temperature from the ice or liquid mixing ratio. ! ! This is truly the inverse of eslf and esif. ! !---------------------------------------------------------------------------------------! - real function tslif(pvap,useice) - use consts_coms, only: es3ple,alvl,alvi + real(kind=4) function tslif(pvap,useice) + use consts_coms, only : es3ple ! ! intent(in) implicit none - real , intent(in) :: pvap - logical, intent(in), optional :: useice - logical :: brrr_cold - + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: pvap ! Vapour pressure [ Pa] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] + !----- Local variables. -------------------------------------------------------------! + logical :: frozen ! Will use ice thermodynamics [ T|F] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! - ! Since pvap is a function of temperature only, we can check the triple point ! + ! Since pvap is a function of temperature only, we can check the triple point ! ! from the saturation at the triple point, like what we would do for temperature. ! !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. pvap < es3ple + frozen = useice .and. pvap < es3ple else - brrr_cold = bulk_on .and. pvap < es3ple + frozen = bulk_on .and. pvap < es3ple end if + !------------------------------------------------------------------------------------! - if (brrr_cold) then + !------------------------------------------------------------------------------------! + ! Call the function depending on whether we should use ice. ! + !------------------------------------------------------------------------------------! + if (frozen) then tslif = tsif(pvap) else tslif = tslf(pvap) end if + !------------------------------------------------------------------------------------! return end function tslif @@ -977,19 +1559,34 @@ end function tslif !=======================================================================================! !=======================================================================================! ! This fucntion computes the dew point temperature given the pressure and vapour ! - ! mixing ratio. THIS IS DEWPOINT ONLY, WHICH MEANS THAT IT WILL IGNORE ICE EFFECT. For ! - ! a full, triple-point dependent routine use DEWFROSTPOINT ! + ! mixing ratio. THIS IS DEW POINT ONLY, WHICH MEANS THAT IT WILL IGNORE ICE EFFECT. For ! + ! a full, triple-point dependent routine use DEWFROSTPOINT. ! !---------------------------------------------------------------------------------------! - real function dewpoint(pres,rsat) - use consts_coms, only: ep,toodry - + real(kind=4) function dewpoint(pres,rsat) + use consts_coms, only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real, intent(in) :: pres, rsat - real :: rsatoff, pvsat - + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: rsatoff ! Non-singular saturation mixing ratio [ kg/kg] + real(kind=4) :: pvsat ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- Make sure mixing ratio is positive. ------------------------------------------! rsatoff = max(toodry,rsat) - pvsat = pres*rsatoff / (ep + rsatoff) + !------------------------------------------------------------------------------------! + + + !----- Find the saturation vapour pressure. -----------------------------------------! + pvsat = pres * rsatoff / (ep + rsatoff) + !------------------------------------------------------------------------------------! + + !----- Dew point is going to be the saturation temperature. -------------------------! dewpoint = tslf(pvsat) + !------------------------------------------------------------------------------------! return end function dewpoint @@ -1004,19 +1601,34 @@ end function dewpoint !=======================================================================================! !=======================================================================================! ! This fucntion computes the frost point temperature given the pressure and vapour ! - ! mixing ratio. THIS IS FROSTPOINT ONLY, WHICH MEANS THAT IT WILL IGNORE LIQUID EFFECT. ! - ! For a full, triple-point dependent routine use DEWFROSTPOINT ! + ! mixing ratio. THIS IS FROST POINT ONLY, WHICH MEANS THAT IT WILL IGNORE LIQUID ! + ! EFFECT. For a full, triple-point dependent routine use DEWFROSTPOINT. ! !---------------------------------------------------------------------------------------! - real function frostpoint(pres,rsat) - use consts_coms, only: ep,toodry - + real(kind=4) function frostpoint(pres,rsat) + use consts_coms, only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real, intent(in) :: pres, rsat - real :: rsatoff, pvsat - + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Local variables for iterative method. ----------------------------------------! + real(kind=4) :: rsatoff ! Non-singular saturation mixing ratio [ kg/kg] + real(kind=4) :: pvsat ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- Make sure mixing ratio is positive. ------------------------------------------! rsatoff = max(toodry,rsat) + !------------------------------------------------------------------------------------! + + + !----- Find the saturation vapour pressure. -----------------------------------------! pvsat = pres*rsatoff / (ep + rsatoff) + !------------------------------------------------------------------------------------! + + !----- Frost point is going to be the saturation temperature. -----------------------! frostpoint = tsif(pvsat) + !------------------------------------------------------------------------------------! return end function frostpoint @@ -1034,21 +1646,37 @@ end function frostpoint ! vapour mixing ratio. This will check whether the vapour pressure is above or below ! ! the triple point vapour pressure, finding dewpoint or frostpoint accordingly. ! !---------------------------------------------------------------------------------------! - real function dewfrostpoint(pres,rsat,useice) - use consts_coms, only: ep,toodry + real(kind=4) function dewfrostpoint(pres,rsat,useice) + use consts_coms, only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real , intent(in) :: pres, rsat - logical, intent(in), optional :: useice - real :: rsatoff, pvsat + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: rsatoff ! Non-singular sat. mix. rat. [ kg/kg] + real(kind=4) :: pvsat ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + - rsatoff = max(toodry,rsat) + !----- Make sure mixing ratio is positive. ------------------------------------------! + rsatoff = max(toodry,rsat) + !------------------------------------------------------------------------------------! + + !----- Find the saturation vapour pressure. -----------------------------------------! pvsat = pres*rsatoff / (ep + rsatoff) + !------------------------------------------------------------------------------------! + + !----- Dew (frost) point is going to be the saturation temperature. -----------------! if (present(useice)) then dewfrostpoint = tslif(pvsat,useice) else dewfrostpoint = tslif(pvsat) end if + !------------------------------------------------------------------------------------! return end function dewfrostpoint !=======================================================================================! @@ -1061,28 +1689,52 @@ end function dewfrostpoint !=======================================================================================! !=======================================================================================! - ! This function computes the vapour mixing ratio based on the pressure [Pa], tem- ! - ! perature [K] and relative humidity [fraction]. IT ALWAYS ASSUME THAT RELATIVE HUMI- ! - ! DITY IS WITH RESPECT TO THE LIQUID PHASE. ptrh2rvapil checks which one to use ! - ! depending on whether temperature is more or less than the triple point. ! + ! This function computes the vapour mixing ratio (or specific humidity) based on ! + ! the pressure [Pa], temperature [K] and relative humidity [fraction]. IT ALWAYS ! + ! ASSUMES THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE LIQUID PHASE. Ptrh2rvapil ! + ! checks which one to use depending on whether temperature is more or less than the ! + ! triple point. ! !---------------------------------------------------------------------------------------! - real function ptrh2rvapl(relh,pres,temp) - use consts_coms, only: ep,toodry - + real(kind=4) function ptrh2rvapl(relh,pres,temp,out_shv) + use consts_coms, only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real , intent(in) :: relh, pres, temp - real :: rsath, relhh - rsath = max(toodry,rslf(pres,temp)) + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: relh ! Relative humidity [ --] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + logical , intent(in) :: out_shv ! Output is specific humidity [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: pvap ! Vapour pressure [ Pa] + real(kind=4) :: relhh ! Bounded relative humidity [ --] + !------------------------------------------------------------------------------------! + + + + !---- Make sure relative humidity is bounded. ---------------------------------------! relhh = min(1.,max(0.,relh)) + !------------------------------------------------------------------------------------! - if (newthermo) then - !----- Considering that Rel.Hum. is based on vapour pressure ---------------------! - ptrh2rvapl = max(toodry,ep * relhh * rsath / (ep + (1.-relhh)*rsath)) + + !---- Find the vapour pressure. -----------------------------------------------------! + pvap = relhh * eslf(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Convert the output to the sought humidity variable. ! + !------------------------------------------------------------------------------------! + if (out_shv) then + !----- Specific humidity. --------------------------------------------------------! + ptrh2rvapl = max(toodry, ep * pvap / (pres - (1.0 - ep) * pvap)) + !---------------------------------------------------------------------------------! else - !----- Original RAMS way to compute mixing ratio ---------------------------------! - ptrh2rvapl = max(toodry,relhh*rsath) + !----- Mixing ratio. -------------------------------------------------------------! + ptrh2rvapl = max(toodry, ep * pvap / (pres - pvap)) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return end function ptrh2rvapl @@ -1096,28 +1748,52 @@ end function ptrh2rvapl !=======================================================================================! !=======================================================================================! - ! This function computes the vapour mixing ratio based on the pressure [Pa], tem- ! - ! perature [K] and relative humidity [fraction]. IT ALWAYS ASSUME THAT RELATIVE HUMI- ! - ! DITY IS WITH RESPECT TO THE ICE PHASE. ptrh2rvapil checks which one to use depending ! - ! on whether temperature is more or less than the triple point. ! + ! This function computes the vapour mixing ratio (or specific humidity) based on ! + ! the pressure [Pa], temperature [K] and relative humidity [fraction]. IT ALWAYS ! + ! ASSUMES THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE ICE PHASE. Ptrh2rvapil ! + ! checks which one to use depending on whether temperature is more or less than the ! + ! triple point. ! !---------------------------------------------------------------------------------------! - real function ptrh2rvapi(relh,pres,temp) - use consts_coms, only: ep,toodry - + real(kind=4) function ptrh2rvapi(relh,pres,temp,out_shv) + use consts_coms, only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real , intent(in) :: relh, pres, temp - real :: rsath, relhh - rsath = max(toodry,rsif(pres,temp)) + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: relh ! Relative humidity [ --] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + logical , intent(in) :: out_shv ! Output is specific humidity [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: pvap ! Vapour pressure [ Pa] + real(kind=4) :: relhh ! Bounded relative humidity [ --] + !------------------------------------------------------------------------------------! + + + + !---- Make sure relative humidity is bounded. ---------------------------------------! relhh = min(1.,max(0.,relh)) + !------------------------------------------------------------------------------------! - if (newthermo) then - !----- Considering that Rel.Hum. is based on vapour pressure ---------------------! - ptrh2rvapi = max(toodry,ep * relhh * rsath / (ep + (1.-relhh)*rsath)) + + !---- Find the vapour pressure. -----------------------------------------------------! + pvap = relhh * esif(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Convert the output to the sought humidity variable. ! + !------------------------------------------------------------------------------------! + if (out_shv) then + !----- Specific humidity. --------------------------------------------------------! + ptrh2rvapi = max(toodry, ep * pvap / (pres - (1.0 - ep) * pvap)) + !---------------------------------------------------------------------------------! else - !----- Original RAMS way to compute mixing ratio ---------------------------------! - ptrh2rvapi = max(toodry,relhh*rsath) + !----- Mixing ratio. -------------------------------------------------------------! + ptrh2rvapi = max(toodry, ep * pvap / (pres - pvap)) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return end function ptrh2rvapi @@ -1131,36 +1807,67 @@ end function ptrh2rvapi !=======================================================================================! !=======================================================================================! - ! This function computes the vapour mixing ratio based on the pressure [Pa], tem- ! - ! perature [K] and relative humidity [fraction]. It will check the temperature to ! - ! decide between ice or liquid saturation and whether ice should be considered. ! + ! This function computes the vapour mixing ratio based (or specific humidity) based ! + ! on the pressure [Pa], temperature [K] and relative humidity [fraction]. It checks ! + ! the temperature to decide between ice or liquid saturation. ! !---------------------------------------------------------------------------------------! - real function ptrh2rvapil(relh,pres,temp,useice) - use consts_coms, only: ep,toodry,t3ple + real(kind=4) function ptrh2rvapil(relh,pres,temp,out_shv,useice) + use consts_coms, only : ep & ! intent(in) + , toodry & ! intent(in) + , t3ple ! ! intent(in) implicit none - real , intent(in) :: relh, pres, temp - logical, intent(in), optional :: useice - real :: rsath, relhh - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: relh ! Relative humidity [ --] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + logical , intent(in) :: out_shv ! Output is specific humidity [ T|F] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: pvap ! Vapour pressure [ Pa] + real(kind=4) :: relhh ! Bounded relative humidity [ --] + logical :: frozen ! Will use ice thermodynamics [ T|F] + !------------------------------------------------------------------------------------! - !----- Checking whether I use the user or the default check for ice saturation. -----! + + !----- Check whether to use the user's or the default flag for ice saturation. ------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple end if + !------------------------------------------------------------------------------------! - if (brrr_cold) then - rsath = max(toodry,rsif(pres,temp)) + + + !---- Make sure relative humidity is bounded. ---------------------------------------! + relhh = min(1.,max(0.,relh)) + !------------------------------------------------------------------------------------! + + + !---- Find the vapour pressure (ice or liquid, depending on the value of frozen). ---! + if (frozen) then + pvap = relhh * esif(temp) else - rsath = max(toodry,rslf(pres,temp)) + pvap = relhh * eslf(temp) end if + !------------------------------------------------------------------------------------! - relhh = min(1.,max(0.,relh)) - - ptrh2rvapil = max(toodry,ep * relhh * rsath / (ep + (1.-relhh)*rsath)) + !------------------------------------------------------------------------------------! + ! Convert the output to the sought humidity variable. ! + !------------------------------------------------------------------------------------! + if (out_shv) then + !----- Specific humidity. --------------------------------------------------------! + ptrh2rvapil = max(toodry, ep * pvap / (pres - (1.0 - ep) * pvap)) + !---------------------------------------------------------------------------------! + else + !----- Mixing ratio. -------------------------------------------------------------! + ptrh2rvapil = max(toodry, ep * pvap / (pres - pvap)) + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! return end function ptrh2rvapil !=======================================================================================! @@ -1174,32 +1881,51 @@ end function ptrh2rvapil !=======================================================================================! !=======================================================================================! ! This function computes the relative humidity [fraction] based on pressure, tem- ! - ! perature, and vapour mixing ratio. Two important points: ! + ! perature, and vapour mixing ratio (or specific humidity). Two important points: ! ! 1. IT ALWAYS ASSUME THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE LIQUID PHASE. ! ! If you want to switch between ice and liquid, use rehuil instead. ! ! 2. IT DOESN'T PREVENT SUPERSATURATION TO OCCUR. This is because this subroutine is ! ! also used in the microphysics, where supersaturation does happen and needs to be ! ! accounted. ! !---------------------------------------------------------------------------------------! - real function rehul(pres,temp,rvap) - use consts_coms, only: ep,toodry + real(kind=4) function rehul(pres,temp,humi,is_shv) + use consts_coms, only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: pres ! Air pressure [ Pa] - real , intent(in) :: temp ! Temperature [ K] - real , intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] + real(kind=4), intent(in) :: pres ! Air pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: humi ! Humidity [ kg/kg] + logical , intent(in) :: is_shv ! Input humidity is specific humidity [ T|F] !----- Local variables --------------------------------------------------------------! - real :: rvapsat ! Saturation mixing ratio [ kg/kg] + real(kind=4) :: shv ! Specific humidity [ kg/kg] + real(kind=4) :: pvap ! Vapour pressure [ Pa] + real(kind=4) :: psat ! Saturation vapour pressure [ Pa] !------------------------------------------------------------------------------------! - rvapsat = max(toodry,rslf(pres,temp)) - if (newthermo) then - !----- This is based on relative humidity being defined with vapour pressure -----! - rehul = max(0.,rvap*(ep+rvapsat)/(rvapsat*(ep+rvap))) + + !---- Make sure that we have specific humidity. -------------------------------------! + if (is_shv) then + shv = max(toodry,humi) else - !----- Original formula used by RAMS ---------------------------------------------! - rehul = max(0.,rvap/rvapsat) + shv = max(toodry,humi) / ( 1.0 + max(toodry,humi) ) end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the vapour pressure and the saturation vapour pressure. ! + !------------------------------------------------------------------------------------! + pvap = ( pres * shv ) / ( ep + (1.0 - ep) * shv ) + psat = eslf (temp) + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Find the relative humidity. ! + !------------------------------------------------------------------------------------! + rehul = max(0. ,pvap / psat) + !------------------------------------------------------------------------------------! + return end function rehul !=======================================================================================! @@ -1213,33 +1939,52 @@ end function rehul !=======================================================================================! !=======================================================================================! ! This function computes the relative humidity [fraction] based on pressure, tem- ! - ! perature, and vapour mixing ratio. Two important points: ! + ! perature, and vapour mixing ratio (or specific humidity). Two important points: ! ! 1. IT ALWAYS ASSUME THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE ICE PHASE. ! ! If you want to switch between ice and liquid, use rehuil instead. ! ! 2. IT DOESN'T PREVENT SUPERSATURATION TO OCCUR. This is because this subroutine is ! ! also used in the microphysics, where supersaturation does happen and needs to be ! ! accounted. ! !---------------------------------------------------------------------------------------! - real function rehui(pres,temp,rvap) - use consts_coms, only: ep,toodry + real(kind=4) function rehui(pres,temp,humi,is_shv) + use consts_coms, only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: pres ! Air pressure [ Pa] - real , intent(in) :: temp ! Temperature [ K] - real , intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] + real(kind=4), intent(in) :: pres ! Air pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: humi ! Humidity [ kg/kg] + logical , intent(in) :: is_shv ! Input humidity is specific humidity [ T|F] !----- Local variables --------------------------------------------------------------! - real :: rvapsat ! Saturation mixing ratio [ kg/kg] + real(kind=4) :: shv ! Specific humidity [ kg/kg] + real(kind=4) :: pvap ! Vapour pressure [ Pa] + real(kind=4) :: psat ! Saturation vapour pressure [ Pa] !------------------------------------------------------------------------------------! - rvapsat = max(toodry,rsif(pres,temp)) - if (newthermo) then - !----- This is based on relative humidity being defined with vapour pressure -----! - rehui = max(0.,rvap*(ep+rvapsat)/(rvapsat*(ep+rvap))) + + !---- Make sure that we have specific humidity. -------------------------------------! + if (is_shv) then + shv = max(toodry,humi) else - !----- Original formula used by RAMS ---------------------------------------------! - rehui = max(0.,rvap/rvapsat) + shv = max(toodry,humi) / ( 1.0 + max(toodry,humi) ) end if - return + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the vapour pressure and the saturation vapour pressure. ! + !------------------------------------------------------------------------------------! + pvap = ( pres * shv ) / ( ep + (1.0 - ep) * shv ) + psat = esif (temp) + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Find the relative humidity. ! + !------------------------------------------------------------------------------------! + rehui = max(0. ,pvap / psat) + !------------------------------------------------------------------------------------! + + return end function rehui !=======================================================================================! !=======================================================================================! @@ -1252,7 +1997,7 @@ end function rehui !=======================================================================================! !=======================================================================================! ! This function computes the relative humidity [fraction] based on pressure, tem- ! - ! perature, and vapour mixing ratio. Two important points: ! + ! perature, and vapour mixing ratio (or specific humidity). Two important points: ! ! 1. It may consider whether the temperature is above or below the freezing point ! ! to choose which saturation to use. It is possible to explicitly force not to use ! ! ice in case level is 2 or if you have reasons not to use ice (e.g. reading data ! @@ -1261,33 +2006,62 @@ end function rehui ! also used in the microphysics, where supersaturation does happen and needs to be ! ! accounted. ! !---------------------------------------------------------------------------------------! - real function rehuil(pres,temp,rvap,useice) - use consts_coms, only: t3ple + real(kind=4) function rehuil(pres,temp,humi,is_shv,useice) + use consts_coms, only : t3ple & ! intent(in) + , ep & ! intent(in) + , toodry ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: pres ! Air pressure [ Pa] - real , intent(in) :: temp ! Temperature [ K] - real , intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] - logical, intent(in), optional :: useice ! Should I consider ice? [ T|F] + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Air pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: humi ! Humidity [ kg/kg] + logical , intent(in) :: is_shv ! Input is specific humidity [ T|F] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] !----- Local variables --------------------------------------------------------------! - real :: rvapsat ! Saturation mixing ratio [ kg/kg] - logical :: brrr_cold ! I will use ice saturation now [ T|F] + real(kind=4) :: shv ! Specific humidity [ kg/kg] + real(kind=4) :: pvap ! Vapour pressure [ Pa] + real(kind=4) :: psat ! Saturation vapour pressure [ Pa] + logical :: frozen ! Will use ice saturation now [ T|F] !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! - ! Checking whether I should go with ice or liquid saturation. ! + ! Check whether we should use ice or liquid saturation. ! !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple + end if + !------------------------------------------------------------------------------------! + + + !---- Make sure that we have specific humidity. -------------------------------------! + if (is_shv) then + shv = max(toodry,humi) + else + shv = max(toodry,humi) / ( 1.0 + max(toodry,humi) ) end if + !------------------------------------------------------------------------------------! - if (brrr_cold) then - rehuil = rehui(pres,temp,rvap) + + !------------------------------------------------------------------------------------! + ! Find the vapour pressure and the saturation vapour pressure. ! + !------------------------------------------------------------------------------------! + pvap = ( pres * shv ) / ( ep + (1.0 - ep) * shv ) + if (frozen) then + psat = esif (temp) else - rehuil = rehul(pres,temp,rvap) + psat = esif (temp) end if + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Find the relative humidity. ! + !------------------------------------------------------------------------------------! + rehuil = max(0. ,pvap / psat) + !------------------------------------------------------------------------------------! return end function rehuil @@ -1307,23 +2081,33 @@ end function rehuil ! 2. This can be used for virtual potential temperature, just give potential tempera- ! ! ture instead of temperature. ! !---------------------------------------------------------------------------------------! - real function tv2temp(tvir,rvap,rtot) - use consts_coms, only: epi + real(kind=4) function tv2temp(tvir,rvap,rtot) + use consts_coms, only : epi ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: tvir ! Virtual temperature [ K] - real, intent(in) :: rvap ! Vapour mixing ratio [kg/kg] - real, intent(in), optional :: rtot ! Total mixing ratio [kg/kg] - !----- Local variable ---------------------------------------------------------------! - real :: rtothere ! Internal rtot, to deal with optional [kg/kg] + real(kind=4), intent(in) :: tvir ! Virtual temperature [ K] + real(kind=4), intent(in) :: rvap ! Vapour mixing ratio [kg/kg] + real(kind=4), intent(in), optional :: rtot ! Total mixing ratio [kg/kg] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: rtothere ! Total or vapour mixing ratio [kg/kg] + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Prefer using total mixing ratio, but if it isn't provided, then use vapour ! + ! as total (no condensation). ! + !------------------------------------------------------------------------------------! if (present(rtot)) then rtothere = rtot else rtothere = rvap end if + !------------------------------------------------------------------------------------! + + !----- Convert using a generalised function. ----------------------------------------! tv2temp = tvir * (1. + rtothere) / (1. + epi*rvap) + !------------------------------------------------------------------------------------! return end function tv2temp @@ -1343,23 +2127,33 @@ end function tv2temp ! 2. This can be used for virtual potential temperature, just give potential tempera- ! ! ture instead of temperature. ! !---------------------------------------------------------------------------------------! - real function virtt(temp,rvap,rtot) - use consts_coms, only: epi + real(kind=4) function virtt(temp,rvap,rtot) + use consts_coms, only: epi ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: rvap ! Vapour mixing ratio [kg/kg] - real, intent(in), optional :: rtot ! Total mixing ratio [kg/kg] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rvap ! Vapour mixing ratio [kg/kg] + real(kind=4), intent(in), optional :: rtot ! Total mixing ratio [kg/kg] !----- Local variable ---------------------------------------------------------------! - real :: rtothere ! Internal rtot, to deal with optional [kg/kg] + real(kind=4) :: rtothere ! Total or vapour mixing ratio [kg/kg] + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Prefer using total mixing ratio, but if it isn't provided, then use vapour ! + ! as total (no condensation). ! + !------------------------------------------------------------------------------------! if (present(rtot)) then rtothere = rtot else rtothere = rvap end if + !------------------------------------------------------------------------------------! + + !----- Convert using a generalised function. ----------------------------------------! virtt = temp * (1. + epi * rvap) / (1. + rtothere) + !------------------------------------------------------------------------------------! return end function virtt @@ -1377,24 +2171,34 @@ end function virtt ! gas law. The condensed phase will be taken into account if the user provided both ! ! the vapour and the total mixing ratios. ! !---------------------------------------------------------------------------------------! - real function idealdens(pres,temp,rvap,rtot) - use consts_coms, only: rdry + real(kind=4) function idealdens(pres,temp,rvap,rtot) + use consts_coms, only : rdry ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: rvap ! Vapour mixing ratio [kg/kg] - real, intent(in), optional :: rtot ! Total mixing ratio [kg/kg] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] + real(kind=4), intent(in), optional :: rtot ! Total mixing ratio [ kg/kg] !----- Local variable ---------------------------------------------------------------! - real :: tvir ! Virtual temperature [ K] + real(kind=4) :: tvir ! Virtual temperature [ K] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Prefer using total mixing ratio, but if it isn't provided, then use vapour ! + ! as total (no condensation). ! !------------------------------------------------------------------------------------! if (present(rtot)) then tvir = virtt(temp,rvap,rtot) else tvir = virtt(temp,rvap) end if + !------------------------------------------------------------------------------------! + + !----- Convert using the definition of virtual temperature. -------------------------! idealdens = pres / (rdry * tvir) + !------------------------------------------------------------------------------------! return end function idealdens @@ -1412,26 +2216,35 @@ end function idealdens ! gas law. The only difference between this function and the one above is that here we ! ! provide vapour and total specific mass (specific humidity) instead of mixing ratio. ! !---------------------------------------------------------------------------------------! - real function idealdenssh(pres,temp,qvpr,qtot) + real(kind=4) function idealdenssh(pres,temp,qvpr,qtot) use consts_coms, only : rdry & ! intent(in) , epi ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: qvpr ! Vapour specific mass [kg/kg] - real, intent(in), optional :: qtot ! Total water specific mass [kg/kg] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: qvpr ! Vapour specific mass [ kg/kg] + real(kind=4), intent(in), optional :: qtot ! Total water specific mass [ kg/kg] !----- Local variables. -------------------------------------------------------------! - real :: qall ! Either qtot or qvpr... [kg/kg] + real(kind=4) :: qall ! Either qtot or qvpr... [ kg/kg] !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Prefer using total specific humidity, but if it isn't provided, then use ! + ! vapour phase as the total (no condensation). ! + !------------------------------------------------------------------------------------! if (present(qtot)) then qall = qtot else qall = qvpr end if + !------------------------------------------------------------------------------------! + + !----- Convert using a generalised function. ----------------------------------------! idealdenssh = pres / (rdry * temp * (1. - qall + epi * qvpr)) + !------------------------------------------------------------------------------------! return end function idealdenssh @@ -1446,27 +2259,28 @@ end function idealdenssh !=======================================================================================! !=======================================================================================! ! This function computes reduces the pressure from the reference height to the ! - ! canopy height by assuming hydrostatic equilibrium. ! + ! canopy height by assuming hydrostatic equilibrium. For simplicity, we assume that ! + ! R and cp are constants (in reality they are dependent on humidity). ! !---------------------------------------------------------------------------------------! - real function reducedpress(pres,thetaref,shvref,zref,thetacan,shvcan,zcan) + real(kind=4) function reducedpress(pres,thetaref,shvref,zref,thetacan,shvcan,zcan) use consts_coms, only : epim1 & ! intent(in) , p00k & ! intent(in) , rocp & ! intent(in) , cpor & ! intent(in) - , cp & ! intent(in) + , cpdry & ! intent(in) , grav ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: thetaref ! Potential temperature [ K] - real, intent(in) :: shvref ! Vapour specific mass [ kg/kg] - real, intent(in) :: zref ! Height at reference level [ m] - real, intent(in) :: thetacan ! Potential temperature [ K] - real, intent(in) :: shvcan ! Vapour specific mass [ kg/kg] - real, intent(in) :: zcan ! Height at canopy level [ m] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: thetaref ! Potential temperature [ K] + real(kind=4), intent(in) :: shvref ! Vapour specific mass [ kg/kg] + real(kind=4), intent(in) :: zref ! Height at reference level [ m] + real(kind=4), intent(in) :: thetacan ! Potential temperature [ K] + real(kind=4), intent(in) :: shvcan ! Vapour specific mass [ kg/kg] + real(kind=4), intent(in) :: zcan ! Height at canopy level [ m] !------Local variables. -------------------------------------------------------------! - real :: pinc ! Pressure increment [ Pa^R/cp] - real :: thvbar ! Average virtual pot. temperature [ K] + real(kind=4) :: pinc ! Pressure increment [ Pa^R/cp] + real(kind=4) :: thvbar ! Average virtual pot. temperature [ K] !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! @@ -1474,12 +2288,19 @@ real function reducedpress(pres,thetaref,shvref,zref,thetacan,shvcan,zcan) ! top and the reference level. ! !------------------------------------------------------------------------------------! thvbar = 0.5 * (thetaref * (1. + epim1 * shvref) + thetacan * (1. + epim1 * shvcan)) + !------------------------------------------------------------------------------------! + + !----- Then, we find the pressure gradient scale. -----------------------------------! - pinc = grav * p00k * (zref - zcan) / (cp * thvbar) + pinc = grav * p00k * (zref - zcan) / (cpdry * thvbar) + !------------------------------------------------------------------------------------! + + !----- And we can find the reduced pressure. ----------------------------------------! reducedpress = (pres**rocp + pinc ) ** cpor + !------------------------------------------------------------------------------------! return end function reducedpress @@ -1494,48 +2315,28 @@ end function reducedpress !=======================================================================================! !=======================================================================================! - ! This function computes the enthalpy given the pressure, temperature, vapour ! - ! specific humidity, and height. Currently it doesn't compute mixed phase air, but ! - ! adding it should be straight forward (finding the inverse is another story...). ! + ! This function computes the Exner function [J/kg/K], given the pressure. It ! + ! assumes for simplicity that R and Cp are constants and equal to the dry air values. ! !---------------------------------------------------------------------------------------! - real function ptqz2enthalpy(pres,temp,qvpr,zref) - use consts_coms, only : ep & ! intent(in) - , grav & ! intent(in) - , t3ple & ! intent(in) - , eta3ple & ! intent(in) - , cimcp & ! intent(in) - , clmcp & ! intent(in) - , cp & ! intent(in) - , alvi ! ! intent(in) + real(kind=4) function press2exner(pres) + use consts_coms, only : p00i & ! intent(in) + , cpdry & ! intent(in) + , rocp ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: qvpr ! Vapour specific mass [ kg/kg] - real, intent(in) :: zref ! Reference height [ m] - !------Local variables. -------------------------------------------------------------! - real :: tequ ! Dew-frost temperature [ K] - real :: pequ ! Equlibrium vapour pressure [ Pa] + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] !------------------------------------------------------------------------------------! - !----- First, we find the equilibrium vapour pressure and dew/frost point. ----------! - pequ = pres * qvpr / (ep + (1. - ep) * qvpr) - tequ = tslif(pequ) !------------------------------------------------------------------------------------! - ! Then, based on dew/frost point, we compute the enthalpy. This accounts whether ! - ! we would have to dew or frost formation if the temperature dropped to the ! - ! equilibrium point. Notice that if supersaturation exists, this will still give a ! - ! number that makes sense, similar to the internal energy of supercooled water. ! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + press2exner = cpdry * ( pres * p00i ) ** rocp !------------------------------------------------------------------------------------! - if (tequ <= t3ple) then - ptqz2enthalpy = cp * temp + qvpr * (cimcp * tequ + alvi ) + grav * zref - else - ptqz2enthalpy = cp * temp + qvpr * (clmcp * tequ + eta3ple) + grav * zref - end if return - end function ptqz2enthalpy + end function press2exner !=======================================================================================! !=======================================================================================! @@ -1544,52 +2345,32 @@ end function ptqz2enthalpy + !=======================================================================================! !=======================================================================================! - ! This function computes the temperature given the enthalpy, pressure, vapour ! - ! specific humidity, and reference height. Currently it doesn't compute mixed phase ! - ! air, but adding it wouldn't be horribly hard, though it would require some root ! - ! finding. ! + ! This function computes the pressure [Pa], given the Exner function. Like in the ! + ! function above, we also assume R and Cp to be constants and equal to the dry air ! + ! values. ! !---------------------------------------------------------------------------------------! - real function hpqz2temp(enthalpy,pres,qvpr,zref) - use consts_coms, only : ep & ! intent(in) - , grav & ! intent(in) - , t3ple & ! intent(in) - , eta3ple & ! intent(in) - , cimcp & ! intent(in) - , clmcp & ! intent(in) - , cpi & ! intent(in) - , alvi ! ! intent(in) + real(kind=4) function exner2press(exner) + use consts_coms, only : p00 & ! intent(in) + , cpdryi & ! intent(in) + , cpor ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: enthalpy ! Enthalpy... [ J/kg] - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: qvpr ! Vapour specific mass [ kg/kg] - real, intent(in) :: zref ! Reference height [ m] - !------Local variables. -------------------------------------------------------------! - real :: tequ ! Dew-frost temperature [ K] - real :: pequ ! Equlibrium vapour pressure [ Pa] + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: exner ! Exner function [ J/kg/K] !------------------------------------------------------------------------------------! - !----- First, we find the equilibrium vapour pressure and dew/frost point. ----------! - pequ = pres * qvpr / (ep + (1. - ep) * qvpr) - tequ = tslif(pequ) !------------------------------------------------------------------------------------! - ! Then, based on dew/frost point, we compute the temperature. This accounts ! - ! whether we would have to dew or frost formation if the temperature dropped to the ! - ! equilibrium point. Notice that if supersaturation exists, this will still give a ! - ! temperature that makes sense (but less than the dew/frost point), similar to the ! - ! internal energy of supercooled water. ! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + exner2press = p00 * ( exner * cpdryi ) ** cpor !------------------------------------------------------------------------------------! - if (tequ <= t3ple) then - hpqz2temp = cpi * (enthalpy - qvpr * (cimcp * tequ + alvi ) - grav * zref) - else - hpqz2temp = cpi * (enthalpy - qvpr * (clmcp * tequ + eta3ple) - grav * zref) - end if return - end function hpqz2temp + end function exner2press !=======================================================================================! !=======================================================================================! @@ -1598,31 +2379,31 @@ end function hpqz2temp + !=======================================================================================! !=======================================================================================! - ! This function finds the temperature given the potential temperature, density, and ! - ! specific humidity. This comes from a combination of the definition of potential ! - ! temperature and the ideal gas law, to eliminate pressure, when pressure is also ! - ! unknown. ! + ! This function computes the potential temperature [K], given the Exner function ! + ! and temperature. For simplicity we ignore the effects of humidity in R and cp and ! + ! use the dry air values instead. ! !---------------------------------------------------------------------------------------! - real(kind=4) function thrhsh2temp(theta,dens,qvpr) - use consts_coms, only : cpocv & ! intent(in) - , p00i & ! intent(in) - , rdry & ! intent(in) - , epim1 & ! intent(in) - , rocv ! ! intent(in) + real(kind=4) function extemp2theta(exner,temp) + use consts_coms, only : cpdry ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=4), intent(in) :: theta ! Potential temperature [ K] - real(kind=4), intent(in) :: dens ! Density [ Pa] - real(kind=4), intent(in) :: qvpr ! Specific humidity [ kg/kg] + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: exner ! Exner function [ J/kg/K] + real(kind=4), intent(in) :: temp ! Temperature [ K] !------------------------------------------------------------------------------------! - thrhsh2temp = theta ** cpocv & - * (p00i * dens * rdry * (1. + epim1 * qvpr)) ** rocv + + !------------------------------------------------------------------------------------! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + extemp2theta = cpdry * temp / exner + !------------------------------------------------------------------------------------! return - end function thrhsh2temp + end function extemp2theta !=======================================================================================! !=======================================================================================! @@ -1631,48 +2412,68 @@ end function thrhsh2temp + !=======================================================================================! !=======================================================================================! - ! This fucntion computes the ice liquid potential temperature given the Exner ! - ! function [J/kg/K], temperature [K], and liquid and ice mixing ratios [kg/kg]. ! + ! This function computes the temperature [K], given the Exner function and ! + ! potential temperature. We simplify the equations by assuming that R and Cp are ! + ! constants. ! !---------------------------------------------------------------------------------------! - real function theta_iceliq(exner,temp,rliq,rice) - use consts_coms, only: alvl, alvi, cp, ttripoli, htripoli, htripolii + real(kind=4) function extheta2temp(exner,theta) + use consts_coms, only : p00i & ! intent(in) + , cpdryi ! ! intent(in) + + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: exner ! Exner function [ J/kg/K] + real(kind=4), intent(in) :: theta ! Potential temperature [ K] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + extheta2temp = cpdryi * exner * theta + !------------------------------------------------------------------------------------! + + return + end function extheta2temp + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the specific (intensive) internal energy of water [J/kg], ! + ! given the temperature and liquid fraction. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function tl2uint(temp,fliq) + use consts_coms, only : cice & ! intent(in) + , cliq & ! intent(in) + , tsupercool_liq ! ! intent(in) + implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: exner ! Exner function [J/kg/K] - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] - real, intent(in) :: rice ! Ice mixing ratio [ kg/kg] - !----- Local variables --------------------------------------------------------------! - real :: hh ! Enthalpy associated with sensible heat [ J/kg] - real :: qq ! Enthalpy associated with latent heat [ J/kg] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: fliq ! Fraction liquid water [ kg/kg] !------------------------------------------------------------------------------------! - !----- Finding the enthalpies -------------------------------------------------------! - hh = cp*temp - qq = alvl*rliq+alvi*rice - - if (newthermo) then - - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli) then - theta_iceliq = hh * exp(-qq/hh) / exner - else - theta_iceliq = hh * exp(-qq * htripolii) / exner - end if - else - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli) then - theta_iceliq = hh * hh / (exner * ( hh + qq)) - else - theta_iceliq = hh * htripoli / (exner * ( htripoli + qq)) - end if - end if + + + !------------------------------------------------------------------------------------! + ! Internal energy is given by the sum of internal energies of ice and liquid ! + ! phases. ! + !------------------------------------------------------------------------------------! + tl2uint = (1.0 - fliq) * cice * temp + fliq * cliq * (temp - tsupercool_liq) + !------------------------------------------------------------------------------------! return - end function theta_iceliq + end function tl2uint !=======================================================================================! !=======================================================================================! @@ -1681,82 +2482,94 @@ end function theta_iceliq + !=======================================================================================! !=======================================================================================! - ! This function computes the liquid potential temperature derivative with respect ! - ! to temperature, useful in iterative methods. ! + ! This function computes the extensive internal energy of water [J/m²] or [ J/m³], ! + ! given the temperature [K], the heat capacity of the "dry" part [J/m²/K] or [J/m³/K], ! + ! water mass [ kg/m²] or [ kg/m³], and liquid fraction [---]. ! !---------------------------------------------------------------------------------------! - real function dthetail_dt(condconst,thil,exner,pres,temp,rliq,ricein) - use consts_coms, only: alvl, alvi, cp, ttripoli,htripoli,htripolii,t3ple + real(kind=4) function cmtl2uext(dryhcap,wmass,temp,fliq) + use consts_coms, only : cice & ! intent(in) + , cliq & ! intent(in) + , tsupercool_liq ! ! intent(in) + + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: dryhcap ! Heat cap. of "dry" part [J/m²/K] or [J/m³/K] + real(kind=4), intent(in) :: wmass ! Water mass [ kg/m²] or [ kg/m³] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: fliq ! Liquid fraction (0-1) [ ---] + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Internal energy is given by the sum of internal energies of dry part, plus the ! + ! contribution of ice and liquid phases. ! + !------------------------------------------------------------------------------------! + cmtl2uext = dryhcap * temp + wmass * ( (1.0 - fliq) * cice * temp & + + fliq * cliq * (temp - tsupercool_liq) ) + !------------------------------------------------------------------------------------! + + return + end function cmtl2uext + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the specific enthalpy [J/kg] given the temperature and ! + ! humidity (either mixing ratio or specific humidity). If we assume that latent heat ! + ! of vaporisation is a linear function of temperature (equivalent to assume that ! + ! specific heats are constants and that the thermal expansion of liquids and solids are ! + ! negligible), then the saturation disappears and the enthalpy becomes a straight- ! + ! forward state function. In case we are accounting for the water exchange only ! + ! (latent heat), set the specific humidity to 1.0 and multiply the result by water mass ! + ! or water flux. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function tq2enthalpy(temp,humi,is_shv) + use consts_coms, only : cpdry & ! intent(in) + , cph2o & ! intent(in) + , tsupercool_vap ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - logical, intent(in) :: condconst ! Condensation is constant? [ T|F] - real , intent(in) :: thil ! Ice liquid pot. temperature [ K] - real , intent(in) :: exner ! Exner function [J/kg/K] - real , intent(in) :: pres ! Pressure [ Pa] - real , intent(in) :: temp ! Temperature [ K] - real , intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] - real , intent(in), optional :: ricein ! Ice mixing ratio [ kg/kg] - !----- Local variables --------------------------------------------------------------! - real :: rice ! Ice mixing ratio or 0. [ kg/kg] - real :: ldrst ! L × d(rs)/dT × T [ J/kg] - real :: hh ! Sensible heat enthalpy [ J/kg] - real :: qq ! Latent heat enthalpy [ J/kg] - logical :: thereisice ! Is ice present [ ---] + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: humi ! Humidity (spec. hum. or mixing ratio) [ kg/kg] + logical , intent(in) :: is_shv ! Input humidity is specific humidity [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: shv ! Specific humidity [ kg/kg] !------------------------------------------------------------------------------------! - + + !------------------------------------------------------------------------------------! - ! Checking whether I should consider ice or not. ! + ! Copy specific humidity to shv. ! !------------------------------------------------------------------------------------! - thereisice = present(ricein) - - if (thereisice) then - rice=ricein - else - rice=0. - end if - - !----- No condensation, dthetail_dt is a constant -----------------------------------! - if (rliq+rice == 0.) then - dthetail_dt = thil/temp - return + if (is_shv) then + shv = humi else - hh = cp*temp !----- Sensible heat enthalpy - qq = alvl*rliq+alvi*rice !----- Latent heat enthalpy - !---------------------------------------------------------------------------------! - ! This is the term L×[d(rs)/dt]×T. L may be either the vapourisation or ! - ! sublimation latent heat, depending on the temperature and whether we are consi- ! - ! dering ice or not. Also, if condensation mixing ratio is constant, then this ! - ! term will be always zero. ! - !---------------------------------------------------------------------------------! - if (condconst) then - ldrst = 0. - elseif (thereisice .and. temp < t3ple) then - ldrst = alvi*rsifp(pres,temp)*temp - else - ldrst = alvl*rslfp(pres,temp)*temp - end if + shv = humi / (humi + 1.0) end if + !------------------------------------------------------------------------------------! + - if (newthermo) then - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli) then - dthetail_dt = thil * (1. + (ldrst + qq)/hh) / temp - else - dthetail_dt = thil * (1. + ldrst*htripolii) / temp - end if - else - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli) then - dthetail_dt = thil * (1. + (ldrst + qq)/(hh+qq)) / temp - else - dthetail_dt = thil * (1. + ldrst/(htripoli + alvl*rliq)) / temp - end if - end if + + !------------------------------------------------------------------------------------! + ! Enthalpy is the combination of dry and moist enthalpies, with the latter being ! + ! allowed to change phase. ! + !------------------------------------------------------------------------------------! + tq2enthalpy = (1.0 - shv) * cpdry * temp + shv * cph2o * (temp - tsupercool_vap) + !------------------------------------------------------------------------------------! return - end function dthetail_dt + end function tq2enthalpy !=======================================================================================! !=======================================================================================! @@ -1765,230 +2578,84 @@ end function dthetail_dt + !=======================================================================================! !=======================================================================================! - ! This function computes temperature from the ice-liquid water potential temperature ! - ! in Kelvin, Exner function in J/kg/K, and liquid and ice mixing ratios in kg/kg. ! - ! For now t1stguess is used only to decide whether I should use the complete case or ! - ! the 253 K to reduce the error on neglecting the changes on latent heat due to temper- ! - ! ature. ! + ! This function computes the temperature [K] given the specific enthalpy and ! + ! humidity. If we assume that latent heat of vaporisation is a linear function of ! + ! temperature (equivalent to assume that specific heats are constants and that the ! + ! thermal expansion of liquid and water are negligible), then the saturation disappears ! + ! and the enthalpy becomes a straightforward state function. In case you are looking ! + ! at water exchange only, set the specific humidity to 1.0 and multiply the result by ! + ! the water mass or water flux. ! !---------------------------------------------------------------------------------------! - real function thil2temp(thil,exner,pres,rliq,rice,t1stguess) - use consts_coms, only: cp, cpi, alvl, alvi, t00, t3ple, ttripoli,htripolii,cpi4 + real(kind=4) function hq2temp(enthalpy,humi,is_shv) + use consts_coms, only : cpdry & ! intent(in) + , cph2o & ! intent(in) + , tsupercool_vap ! ! intent(in) + implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: thil ! Ice-liquid water potential temperature [ K] - real, intent(in) :: exner ! Exner function [J/kg/K] - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] - real, intent(in) :: rice ! Ice mixing ratio [ kg/kg] - real, intent(in) :: t1stguess ! 1st. guess for temperature [ K] - !----- Local variables for iterative method -----------------------------------------! - real :: deriv ! Function derivative - real :: fun ! Function for which we seek a root. - real :: funa ! Smallest guess function - real :: funz ! Largest guess function - real :: tempa ! Smallest guess (or previous guess in Newton) - real :: tempz ! Largest guess (or new guess in Newton) - real :: delta ! Aux. var to compute 2nd guess for bisection - integer :: itn,itb ! Iteration counter - logical :: converged ! Convergence handle - logical :: zside ! Flag to check for one-sided approach... - real :: til ! Ice liquid temperature [ K] + real(kind=4), intent(in) :: enthalpy ! Specific enthalpy [ J/kg] + real(kind=4), intent(in) :: humi ! Humidity (spec. hum. or mixing ratio) [ kg/kg] + logical , intent(in) :: is_shv ! Input humidity is specific humidity [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: shv ! Specific humidity [ kg/kg] !------------------------------------------------------------------------------------! - !----- 1st. of all, check whether there is condensation. If not, theta_il = theta ---! - if (rliq+rice == 0.) then - thil2temp = cpi * thil * exner - return - !----- If not, check whether we are using the old thermo or the new one -------------! - elseif (.not. newthermo) then - til = cpi * thil * exner - if (t1stguess > ttripoli) then - thil2temp = 0.5 * (til + sqrt(til * (til + cpi4 * (alvl*rliq + alvi*rice)))) - else - thil2temp = til * ( 1. + (alvl*rliq+alvi*rice) * htripolii) - end if - return + !------------------------------------------------------------------------------------! + ! Copy specific humidity to shv. ! + !------------------------------------------------------------------------------------! + if (is_shv) then + shv = humi + else + shv = humi / (humi + 1.0) end if !------------------------------------------------------------------------------------! - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,a,1x,f11.4,2(1x,a,1x,es12.5))') & - ! 'itn=',itn,'bisection=',.false.,'tempz=',tempz-t00 & - ! ,'fun=',fun,'deriv=',deriv - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - - converged = abs(tempa-tempz) < toler*tempz - !----- Converged, happy with that, return the average b/w the 2 previous guesses -! - if (fun == 0.) then - thil2temp = tempz - converged = .true. - return - elseif(converged) then - thil2temp = 0.5 * (tempa+tempz) - return - end if - end do newloop - !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! Enthalpy is the combination of dry and moist enthalpies, with the latter being ! + ! allowed to change phase. ! + !------------------------------------------------------------------------------------! + hq2temp = ( enthalpy + shv * cph2o * tsupercool_vap ) & + / ( (1.0 - shv) * cpdry + shv * cph2o ) !------------------------------------------------------------------------------------! - if (funa * fun < 0.) then - funz = fun - zside = .true. - else - if (abs(fun-funa) < toler*tempa) then - delta = 100.*toler*tempa - else - delta = max(abs(funa * (tempz-tempa)/(fun-funa)),100.*toler*tempa) - end if - tempz = tempa + delta - zside = .false. - zgssloop: do itb=1,maxfpo - tempz = tempa + real((-1)**itb * (itb+3)/2) * delta - funz = theta_iceliq(exner,tempz,rliq,rice) - thil - zside = funa*funz < 0 - if (zside) exit zgssloop - end do zgssloop - if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'thil =',thil ,'t1st=',t1stguess - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'exner=',exner,'pres=',pres - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'rliq =',rliq ,'rice=',rice - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempa=',tempa,'funa=',funa - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempz=',tempz,'funz=',funz - write (unit=*,fmt='(1(a,1x,es14.7,1x))') 'delta=',delta - call fatal_error('Failed finding the second guess for regula falsi' & - ,'thil2temp','therm_lib.f90') - end if - end if - - - bisloop: do itb=itn,maxfpo - thil2temp = (funz*tempa-funa*tempz)/(funz-funa) - !---------------------------------------------------------------------------------! - ! Now that we updated the guess, check whether they are really close. If so, ! - ! it converged, I can use this as my guess. ! - !---------------------------------------------------------------------------------! - converged = abs(thil2temp-tempa)< toler*thil2temp - if (converged) exit bisloop + return + end function hq2temp + !=======================================================================================! + !=======================================================================================! - !------ Finding the new function -------------------------------------------------! - fun = theta_iceliq(exner,tempz,rliq,rice) - thil - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,6(1x,a,1x,f11.4))') & - ! 'itn=',itb,'bisection=',.true. & - ! ,'temp=',thil2temp-t00,'tempa=',tempa-t00,'tempz=',tempz-t00 & - ! ,'fun=',fun,'funa=',funa,'funz=',funz - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !------ Defining my new interval based on the intermediate value theorem. --------! - if (fun*funa < 0. ) then - tempz = thil2temp - funz = fun - !----- If we are updating zside again, modify aside (Illinois method) ---------! - if (zside) funa=funa * 0.5 - !----- We just updated zside, setting zside to true. --------------------------! - zside = .true. - else - tempa = thil2temp - funa = fun - !----- If we are updating aside again, modify aside (Illinois method) ---------! - if (.not. zside) funz=funz * 0.5 - !----- We just updated aside, setting aside to true. --------------------------! - zside = .false. - end if - end do bisloop - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> ttripoli) then - dtempdrs = - temp * qhydm / (rcon * (hh+qhydm)) - else - dtempdrs = - temp * qhydm * htripolii / rcon - end if - else - til = cpi * thil * exner - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli) then - dtempdrs = - til * qhydm /( rcon * cp * (2.*temp-til)) - else - dtempdrs = - til * qhydm * htripolii / rcon - end if - end if return - end function dtempdrs + end function alvi !=======================================================================================! !=======================================================================================! @@ -2062,35 +2697,68 @@ end function dtempdrs !=======================================================================================! !=======================================================================================! - ! This fucntion computes the change of ice-liquid potential temperature due to ! - ! sedimentation. The arguments are ice-liquid potential temperature, potential temper- ! - ! ature and temperature in Kelvin, the old and new mixing ratio [kg/kg] and the old and ! - ! new enthalpy [J/kg]. ! + ! This fucntion computes the ice liquid potential temperature given the Exner ! + ! function [J/kg/K], temperature [K], and liquid and ice mixing ratios [kg/kg]. ! !---------------------------------------------------------------------------------------! - real function dthil_sedimentation(thil,theta,temp,rold,rnew,qrold,qrnew) - use consts_coms, only: ttripoli,cp,alvi,alvl + real(kind=4) function theta_iceliq(exner,temp,rliq,rice) + use consts_coms, only : alvl3 & ! intent(in) + , alvi3 & ! intent(in) + , cpdry & ! intent(in) + , ttripoli & ! intent(in) + , htripoli & ! intent(in) + , htripolii ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: thil ! Ice-liquid potential temperature [ K] - real, intent(in) :: theta ! Potential temperature [ K] - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: rold ! Old hydrometeor mixing ratio [ kg/kg] - real, intent(in) :: rnew ! New hydrometeor mixing ratio [ kg/kg] - real, intent(in) :: qrold ! Old hydrometeor latent enthalpy [ J/kg] - real, intent(in) :: qrnew ! New hydrometeor latent enthalpy [ J/kg] + real(kind=4), intent(in) :: exner ! Exner function [ J/kg/K] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] + real(kind=4), intent(in) :: rice ! Ice mixing ratio [ kg/kg] + !----- Local variables --------------------------------------------------------------! + real(kind=4) :: hh ! Enthalpy associated with sensible heat [ J/kg] + real(kind=4) :: qq ! Enthalpy associated with latent heat [ J/kg] + !------------------------------------------------------------------------------------! + + + !----- Find the sensible heat enthalpy (assuming dry air). --------------------------! + hh = cpdry * temp + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Find the latent heat enthalpy. If using the old thermodynamics, we use the ! + ! latent heat at T = T3ple, otherwise we use the temperature-dependent one. ! + !------------------------------------------------------------------------------------! + if (newthermo) then + qq = alvl(temp) * rliq + alvi(temp) * rice + else + qq = alvl3 * rliq + alvi3 * rice + end if + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Solve the thermodynamics. For the new thermodynamics we don't approximate ! + ! the exponential to a linear function, nor do we impose temperature above the thre- ! + ! shold from Tripoli and Cotton (1981). ! + !------------------------------------------------------------------------------------! if (newthermo) then - dthil_sedimentation = - thil * (alvi*(rnew-rold) - (qrnew-qrold)) & - / (cp * max(temp,ttripoli)) + !----- Decide how to compute, based on temperature. ------------------------------! + theta_iceliq = hh * exp(-qq / hh) / exner + !---------------------------------------------------------------------------------! else - dthil_sedimentation = - thil*thil * (alvi*(rnew-rold) - (qrnew-qrold)) & - / (cp * max(temp,ttripoli) * theta) + !----- Decide how to compute, based on temperature. ------------------------------! + if (temp > ttripoli) then + theta_iceliq = hh * hh / (exner * ( hh + qq)) + else + theta_iceliq = hh * htripoli / (exner * ( htripoli + qq)) + end if + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return - end function dthil_sedimentation + end function theta_iceliq !=======================================================================================! !=======================================================================================! @@ -2101,96 +2769,1205 @@ end function dthil_sedimentation !=======================================================================================! !=======================================================================================! - ! This function computes the ice-vapour equivalent potential temperature from ! - ! theta_iland the total mixing ratio. This is equivalent to the equivalent potential ! - ! temperature considering also the effects of fusion/melting/sublimation. ! - ! In case you want to find thetae (i.e. without ice) simply provide the logical ! - ! useice as .false. . ! + ! This function computes the liquid potential temperature derivative with respect ! + ! to temperature, useful in iterative methods. ! !---------------------------------------------------------------------------------------! - real function thetaeiv(thil,pres,temp,rvap,rtot,iflg,useice) - use consts_coms, only : alvl,alvi,cp,ep,p00,rocp,ttripoli,t3ple + real(kind=4) function dthetail_dt(condconst,thil,exner,pres,temp,rliq,ricein) + use consts_coms, only : alvl3 & ! intent(in) + , alvi3 & ! intent(in) + , dcpvi & ! intent(in) + , dcpvl & ! intent(in) + , cpdry & ! intent(in) + , ttripoli & ! intent(in) + , htripoli & ! intent(in) + , htripolii & ! intent(in) + , t3ple ! ! intent(in) + implicit none !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: thil ! Ice-liquid water potential temp. [ K] - real , intent(in) :: pres ! Pressure [ Pa] - real , intent(in) :: temp ! Temperature [ K] - real , intent(in) :: rvap ! Water vapour mixing ratio [ kg/kg] - real , intent(in) :: rtot ! Total mixing ratio [ kg/kg] - integer, intent(in) :: iflg ! Just to tell where this has been called. - logical, intent(in), optional :: useice ! Should I use ice? [ T|F] - !----- Local variables for iterative method -----------------------------------------! - real :: tlcl ! Internal LCL temperature [ K] - real :: plcl ! Lifting condensation pressure [ Pa] - real :: dzlcl ! Thickness of layer beneath LCL [ m] + logical , intent(in) :: condconst ! Condensation is constant? [ T|F] + real(kind=4), intent(in) :: thil ! Ice liquid pot. temp. [ K] + real(kind=4), intent(in) :: exner ! Exner function [J/kg/K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] + real(kind=4), intent(in), optional :: ricein ! Ice mixing ratio [ kg/kg] + !----- Local variables --------------------------------------------------------------! + real(kind=4) :: rice ! Ice mixing ratio or 0. [ kg/kg] + real(kind=4) :: ldrst ! L × d(rs)/dT × T [ J/kg] + real(kind=4) :: rdlt ! r × d(L)/dT × T [ J/kg] + real(kind=4) :: hh ! Sensible heat enthalpy [ J/kg] + real(kind=4) :: qq ! Latent heat enthalpy [ J/kg] + logical :: thereisice ! Is ice present [ ---] !------------------------------------------------------------------------------------! - if (present(useice)) then - call lcl_il(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl,iflg,useice) + + !------------------------------------------------------------------------------------! + ! Check whether we should consider ice thermodynamics or not. ! + !------------------------------------------------------------------------------------! + thereisice = present(ricein) + if (thereisice) then + rice = ricein else - call lcl_il(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl,iflg) + rice = 0. end if + !------------------------------------------------------------------------------------! + !------------------------------------------------------------------------------------! - ! The definition of the thetae_iv is the thetae_ivs at the LCL. The LCL, in turn ! - ! is the point in which rtot = rvap = rsat, so at the LCL rliq = rice = 0. ! + ! Check whether the current state has condensed water. ! !------------------------------------------------------------------------------------! - thetaeiv = thetaeivs(thil,tlcl,rtot,0.,0.) + if (rliq+rice == 0.) then + !----- No condensation, so dthetail_dt is a constant. ----------------------------! + dthetail_dt = thil/temp + return + !---------------------------------------------------------------------------------! + else + !---------------------------------------------------------------------------------! + ! Condensation exists. Compute some auxiliary variables. ! + !---------------------------------------------------------------------------------! - return - end function thetaeiv - !=======================================================================================! - !=======================================================================================! + !---- Sensible heat enthalpy. ----------------------------------------------------! + hh = cpdry * temp + !---------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------! + ! Find the latent heat enthalpy. If using the old thermodynamics, we use ! + ! the latent heat at T = T3ple, otherwise we use the temperature-dependent one. ! + ! The term r × d(L)/dT × T is computed only when we use the new thermodynamics. ! + !---------------------------------------------------------------------------------! + if (newthermo) then + qq = alvl(temp) * rliq + alvi(temp) * rice + rdlt = (dcpvl * rliq + dcpvi * rice ) * temp + else + qq = alvl3 * rliq + alvi3 * rice + rdlt = 0.0 + end if + !---------------------------------------------------------------------------------! - !=======================================================================================! - !=======================================================================================! - ! This function computes the derivative of ice-vapour equivalent potential tempera- ! - ! ture, based on the expression used to compute the ice-vapour equivalent potential ! - ! temperature (function thetaeiv). ! - ! ! - ! IMPORTANT!!! This CANNOT BE USED to compute d(Thetae_ivs)/dT, because here ! - ! we assume that T(LCL) and saturation mixing ratio are known and ! - ! constants, and that the LCL pressure (actually the saturation vapour ! - ! pressure at the LCL) is a function of temperature. In case you want ! - ! d(Thetae_ivs)/dT, use the dthetaeivs_dt function instead. ! - !---------------------------------------------------------------------------------------! - real function dthetaeiv_dtlcl(theiv,tlcl,rtot,eslcl,useice) - use consts_coms, only : rocp,aklv,ttripoli - implicit none - !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: theiv ! Ice-vapour equiv. pot. temp. [ K] - real , intent(in) :: tlcl ! LCL temperature [ K] - real , intent(in) :: rtot ! Total mixing ratio (rs @ LCL) [ Pa] - real , intent(in) :: eslcl ! LCL saturation vapour pressure [ Pa] - logical, intent(in), optional :: useice ! Flag for considering ice [ T|F] - !----- Local variables --------------------------------------------------------------! - real :: desdtlcl ! Saturated vapour pres. deriv. [ Pa/K] + !---------------------------------------------------------------------------------! + ! This is the term L×[d(rs)/dt]×T. L may be either the vapourisation or ! + ! sublimation latent heat, depending on the temperature and whether we are consi- ! + ! dering ice or not. We still need to check whether latent heat is a function of ! + ! temperature or not. Also, if condensation mixing ratio is constant, then this ! + ! term will be always zero. ! + !---------------------------------------------------------------------------------! + if (condconst) then + ldrst = 0. + elseif (thereisice .and. temp < t3ple) then + if (newthermo) then + ldrst = alvi3 * rsifp(pres,temp) * temp + else + ldrst = alvi(temp) * rsifp(pres,temp) * temp + end if + else + if (newthermo) then + ldrst = alvl3 * rslfp(pres,temp) * temp + else + ldrst = alvl(temp) * rslfp(pres,temp) * temp + end if + end if + !---------------------------------------------------------------------------------! + end if !------------------------------------------------------------------------------------! - !----- Finding the derivative of rs with temperature --------------------------------! - if (present(useice)) then - desdtlcl = eslifp(tlcl,useice) + !------------------------------------------------------------------------------------! + ! Find the condensed phase consistent with the thermodynamics used. ! + !------------------------------------------------------------------------------------! + if (newthermo) then + dthetail_dt = thil * ( 1. + (ldrst + qq - rdlt ) / hh ) / temp else - desdtlcl = eslifp(tlcl) + !----- Decide how to compute, based on temperature. ------------------------------! + if (temp > ttripoli) then + dthetail_dt = thil * ( 1. + (ldrst + qq) / (hh+qq) ) / temp + else + dthetail_dt = thil * ( 1. + ldrst / (htripoli + alvl3 * rliq) ) / temp + end if + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + return + end function dthetail_dt + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes temperature from the ice-liquid water potential temperature ! + ! in Kelvin, Exner function in J/kg/K, and liquid and ice mixing ratios in kg/kg. ! + ! For now t1stguess is used only to decide whether I should use the complete case or ! + ! the 253 K to reduce the error on neglecting the changes on latent heat due to temper- ! + ! ature. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function thil2temp(thil,exner,pres,rliq,rice,t1stguess) + use consts_coms, only : cpdry & ! intent(in) + , cpdryi & ! intent(in) + , cpdryi4 & ! intent(in) + , alvl3 & ! intent(in) + , alvi3 & ! intent(in) + , t00 & ! intent(in) + , t3ple & ! intent(in) + , ttripoli & ! intent(in) + , htripolii ! ! intent(in) + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: thil ! Ice-liquid water potential temp. [ K] + real(kind=4), intent(in) :: exner ! Exner function [J/kg/K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] + real(kind=4), intent(in) :: rice ! Ice mixing ratio [ kg/kg] + real(kind=4), intent(in) :: t1stguess ! 1st. guess for temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: til ! Ice liquid temperature [ K] + real(kind=4) :: deriv ! Function derivative + real(kind=4) :: fun ! Function for which we seek a root. + real(kind=4) :: funa ! Smallest guess function + real(kind=4) :: funz ! Largest guess function + real(kind=4) :: tempa ! Smallest guess (or previous guess in Newton) + real(kind=4) :: tempz ! Largest guess (or new guess in Newton) + real(kind=4) :: delta ! Aux. var to compute 2nd guess for bisection + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + logical :: converged ! Convergence flag + logical :: zside ! Flag to check for one-sided approach... + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! First we check for conditions that don't require iterative root-finding. ! + !------------------------------------------------------------------------------------! + if (rliq + rice == 0.) then + !----- No condensation. Theta_il is the same as theta. --------------------------! + thil2temp = cpdryi * thil * exner + return + !---------------------------------------------------------------------------------! + elseif (.not. newthermo) then + !---------------------------------------------------------------------------------! + ! There is condensation but we are using the old thermodynamics, which can be ! + ! solved analytically. ! + !---------------------------------------------------------------------------------! + til = cpdryi * thil * exner + if (t1stguess > ttripoli) then + thil2temp = 0.5 & + * (til + sqrt(til * (til + cpdryi4 * (alvl3 * rliq + alvi3 * rice)))) + else + thil2temp = til * ( 1. + (alvl3 * rliq + alvi3 * rice) * htripolii) + end if + return + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,a,1x,f11.4,2(1x,a,1x,es12.5))') & + ! 'itn=',itn,'bisection=',.false.,'tempz=',tempz-t00 & + ! ,'fun=',fun,'deriv=',deriv + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + converged = abs(tempa-tempz) < toler*tempz + !----- Converged, happy with that, return the average b/w the 2 previous guesses -! + if (fun == 0.) then + thil2temp = tempz + converged = .true. + return + elseif(converged) then + thil2temp = 0.5 * (tempa+tempz) + return + end if + end do newloop + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! If we have reached this point then Newton's method failed. Use bisection ! + ! instead. For bisection, We need two guesses whose function evaluations have ! + ! opposite sign. ! + !------------------------------------------------------------------------------------! + if (funa * fun < 0.) then + !----- Guesses have opposite sign. -----------------------------------------------! + funz = fun + zside = .true. + else + if (abs(fun-funa) < toler*tempa) then + delta = 100.*toler*tempa + else + delta = max(abs(funa * (tempz-tempa)/(fun-funa)),100.*toler*tempa) + end if + tempz = tempa + delta + zside = .false. + zgssloop: do itb=1,maxfpo + tempz = tempa + real((-1)**itb * (itb+3)/2) * delta + funz = theta_iceliq(exner,tempz,rliq,rice) - thil + zside = funa*funz < 0.0 + if (zside) exit zgssloop + end do zgssloop + if (.not. zside) then + write (unit=*,fmt='(a)') ' No second guess for you...' + write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'thil =',thil ,'t1st=',t1stguess + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'exner=',exner,'pres=',pres + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'rliq =',rliq ,'rice=',rice + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempa=',tempa,'funa=',funa + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempz=',tempz,'funz=',funz + write (unit=*,fmt='(1(a,1x,es14.7,1x))') 'delta=',delta + call fatal_error('Failed finding the second guess for regula falsi' & + ,'thil2temp','therm_lib.f90') + end if + end if + + + bisloop: do itb=itn,maxfpo + thil2temp = (funz*tempa-funa*tempz)/(funz-funa) + + !---------------------------------------------------------------------------------! + ! Now that we updated the guess, check whether they are really close. If so, ! + ! it converged, I can use this as my guess. ! + !---------------------------------------------------------------------------------! + converged = abs(thil2temp-tempa)< toler*thil2temp + if (converged) exit bisloop + + !------ Finding the new function -------------------------------------------------! + fun = theta_iceliq(exner,tempz,rliq,rice) - thil + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,6(1x,a,1x,f11.4))') & + ! 'itn=',itb,'bisection=',.true. & + ! ,'temp=',thil2temp-t00,'tempa=',tempa-t00,'tempz=',tempz-t00 & + ! ,'fun=',fun,'funa=',funa,'funz=',funz + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + !------ Defining my new interval based on the intermediate value theorem. --------! + if (fun*funa < 0. ) then + tempz = thil2temp + funz = fun + !----- If we are updating zside again, modify aside (Illinois method) ---------! + if (zside) funa=funa * 0.5 + !----- We just updated zside, setting zside to true. --------------------------! + zside = .true. + else + tempa = thil2temp + funa = fun + !----- If we are updating aside again, modify aside (Illinois method) ---------! + if (.not. zside) funz=funz * 0.5 + !----- We just updated aside, setting aside to true. --------------------------! + zside = .false. + end if + end do bisloop + + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> ttripoli) then + dtempdrs = - til * qq / ( rcon * cpdry * (2.*temp-til)) + else + dtempdrs = - til * qq * htripolii / rcon + end if + !------------------------------------------------------------------------------! + end if + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + return + end function dtempdrs + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the ice-vapour equivalent potential temperature from ! + ! theta_iland the total mixing ratio. This is equivalent to the equivalent potential ! + ! temperature considering also the effects of fusion/melting/sublimation. ! + ! In case you want to find thetae (i.e. without ice) simply set the the logical ! + ! useice to .false. . ! + !---------------------------------------------------------------------------------------! + real(kind=4) function thetaeiv(thil,pres,temp,rvap,rtot,useice) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: thil ! Ice-liquid potential temp. [ K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rvap ! Water vapour mixing ratio [ kg/kg] + real(kind=4), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! Should I use ice? [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: tlcl ! Internal LCL temperature [ K] + real(kind=4) :: plcl ! Lifting condensation pressure [ Pa] + real(kind=4) :: dzlcl ! Thickness of lyr. beneath LCL [ m] + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Find the liquid condensation level (LCL). ! + !------------------------------------------------------------------------------------! + if (present(useice)) then + call lcl_il(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl,useice) + else + call lcl_il(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl) + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! The definition of the thetae_iv is the thetae_ivs at the LCL. The LCL, in turn ! + ! is the point in which rtot = rvap = rsat, so at the LCL rliq = rice = 0. ! + !------------------------------------------------------------------------------------! + thetaeiv = thetaeivs(thil,tlcl,rtot,0.,0.) + !------------------------------------------------------------------------------------! + + return + end function thetaeiv + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the derivative of ice-vapour equivalent potential tempera- ! + ! ture, based on the expression used to compute the ice-vapour equivalent potential ! + ! temperature (function thetaeiv). ! + ! ! + ! IMPORTANT!!! This CANNOT BE USED to compute d(Thetae_ivs)/dT, because here ! + ! we assume that T(LCL) and saturation mixing ratio are known and ! + ! constants, and that the LCL pressure (actually the saturation vapour ! + ! pressure at the LCL) is a function of temperature. In case you want ! + ! d(Thetae_ivs)/dT, use the dthetaeivs_dt function instead. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function dthetaeiv_dtlcl(theiv,tlcl,rtot,eslcl,useice) + use consts_coms, only : rocp & ! intent(in) + , cpdry & ! intent(in) + , dcpvl ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: theiv ! Ice-vap. equiv. pot. temp. [ K] + real(kind=4), intent(in) :: tlcl ! LCL temperature [ K] + real(kind=4), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + real(kind=4), intent(in) :: eslcl ! LCL sat. vapour pressure [ Pa] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! Flag for considering ice [ T|F] + !----- Local variables --------------------------------------------------------------! + real(kind=4) :: desdtlcl ! Sat. vapour pres. deriv. [ Pa/K] + real(kind=4) :: esterm ! es(TLC) term [ ----] + real(kind=4) :: hhlcl ! Enthalpy -- sensible [ J/kg] + real(kind=4) :: qqlcl ! Enthalpy -- latent [ J/kg] + real(kind=4) :: qptlcl ! Latent deriv. * T_LCL [ J/kg] + !------------------------------------------------------------------------------------! + + + + !----- Find the derivative of rs with temperature. ----------------------------------! + if (present(useice)) then + desdtlcl = eslifp(tlcl,useice) + else + desdtlcl = eslifp(tlcl) + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Saturation term. ! + !------------------------------------------------------------------------------------! + esterm = rocp * tlcl * desdtlcl / eslcl + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the enthalpy terms. ! + !------------------------------------------------------------------------------------! + hhlcl = cpdry * tlcl + qqlcl = alvl(tlcl) * rtot + qptlcl = dcpvl * rtot * tlcl + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Derivative. ! + !------------------------------------------------------------------------------------! + dthetaeiv_dtlcl = theiv / tlcl * (1. - esterm - (qqlcl - qptlcl) / hhlcl) + !------------------------------------------------------------------------------------! + + return + end function dthetaeiv_dtlcl + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the saturation ice-vapour equivalent potential temperature ! + ! from theta_il and the total mixing ratio (split into saturated vapour plus liquid and ! + ! ice. This is equivalent to the equivalent potential temperature considering also the ! + ! effects of fusion/melting/sublimation, and it is done separatedly from the regular ! + ! thetae_iv because it doesn't require iterations. ! + ! ! + ! References: ! + ! Tripoli, J. T.; and Cotton, W.R., 1981: The use of ice-liquid water potential tem- ! + ! perature as a thermodynamic variable in deep atmospheric models. Mon. Wea. ! + ! Rev., v. 109, 1094-1102. (TC81) ! + ! ! + ! Some algebra was needed to find this equation, essentially combining (TC81-26) and ! + ! (TC81-27), and the conservation of total water (TC81-16). It assumes that the divi- ! + ! sion between the three phases is already taken care of. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function thetaeivs(thil,temp,rsat,rliq,rice) + use consts_coms, only : cpdry ! ! intent(in) + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: thil ! Theta_il, ice-liquid water pot. temp. [ K] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rsat ! Saturation water vapour mixing ratio [ kg/kg] + real(kind=4), intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] + real(kind=4), intent(in) :: rice ! Ice mixing ratio [ kg/kg] + !----- Local variables --------------------------------------------------------------! + real(kind=4) :: rtots ! Saturated mixing ratio [ K] + !------------------------------------------------------------------------------------! + + + !------ Find the total saturation mixing ratio. -------------------------------------! + rtots = rsat+rliq+rice + !------------------------------------------------------------------------------------! + + + !------ Find the saturation equivalent potential temperature. -----------------------! + thetaeivs = thil * exp ( alvl(temp) * rtots / (cpdry * temp)) + !------------------------------------------------------------------------------------! + + return + end function thetaeivs + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the derivative of saturation ice-vapour equivalent ! + ! potential temperature, based on the expression used to compute the saturation ! + ! ice-vapour equivalent potential temperature (function thetaeivs). ! + ! ! + ! IMPORTANT!!! This CANNOT BE USED to compute d(Thetae_iv)/d(T_LCL), because here ! + ! we assume that temperature and pressure are known and constants, and ! + ! that the mixing ratio is a function of temperature. In case you want ! + ! d(Thetae_iv)/d(T_LCL), use the dthetaeiv_dtlcl function instead. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function dthetaeivs_dt(theivs,temp,pres,rsat,useice) + use consts_coms, only : cpdry & ! intent(in) + , dcpvl ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: theivs ! Sat. ice-vap. eq. pot. temp. [ K] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! Flag for considering ice [ T|F] + !----- Local variables --------------------------------------------------------------! + real(kind=4) :: drsdt ! Sat. mixing ratio derivative [kg/kg/K] + real(kind=4) :: hh ! Enthalpy -- sensible [ J/kg] + real(kind=4) :: qqaux ! Enthalpy -- sensible [ J/kg] + !------------------------------------------------------------------------------------! + + + !----- Find the derivative of rs with temperature and associated term. --------------! + if (present(useice)) then + drsdt = rslifp(pres,temp,useice) + else + drsdt = rslifp(pres,temp) + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Find the enthalpy terms. ! + !------------------------------------------------------------------------------------! + hh = cpdry * temp + qqaux = alvl(temp) * (drsdt * temp - rsat) + dcpvl * rsat * temp + !------------------------------------------------------------------------------------! + + + !----- Find the derivative. Depending on the temperature, use different eqn. -------! + dthetaeivs_dt = theivs / temp * ( 1. + qqaux / hh ) + !------------------------------------------------------------------------------------! + + return + end function dthetaeivs_dt + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function finds the ice-liquid potential temperature from the ice-vapour equi- ! + ! valent potential temperature. ! + ! Important remarks: ! + ! 1. If you don't want to use ice thermodynamics, simply force useice to be .false. ! + ! Otherwise, the model will decide based on the LEVEL given by the user from their ! + ! RAMSIN. ! + ! 2. If rtot < rsat, then this will convert theta_e into theta, which can be thought as ! + ! a particular case. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function thetaeiv2thil(theiv,pres,rtot,useice) + use consts_coms, only : ep & ! intent(in) + , cpdry & ! intent(in) + , p00 & ! intent(in) + , rocp & ! intent(in) + , t3ple & ! intent(in) + , t00 ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: theiv ! Ice vap. equiv. pot. temp. [ K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May I use ice thermodyn. [ T|F] + !----- Local variables for iterative method -----------------------------------------! + real(kind=4) :: pvap ! Sat. vapour pressure + real(kind=4) :: theta ! Potential temperature + real(kind=4) :: deriv ! Function derivative + real(kind=4) :: funnow ! Function for which we seek a root. + real(kind=4) :: funa ! Smallest guess function + real(kind=4) :: funz ! Largest guess function + real(kind=4) :: tlcla ! Smallest guess (Newton: old guess) + real(kind=4) :: tlclz ! Largest guess (Newton: new guess) + real(kind=4) :: tlcl ! What will be the LCL temperature + real(kind=4) :: es00 ! Defined as p00*rt/(epsilon + rt) + real(kind=4) :: delta ! Aux. variable (For 2nd guess). + integer :: itn ! Iteration counters + integer :: itb ! Iteration counters + integer :: ii ! Another counter + logical :: converged ! Convergence handle + logical :: zside ! Side checker for Regula Falsi + logical :: frozen ! Will use ice thermodynamics + !------------------------------------------------------------------------------------! + + + + !----- Fill the flag for ice thermodynamics so it will be present. ------------------! + if (present(useice)) then + frozen = useice + else + frozen = bulk_on + end if + !------------------------------------------------------------------------------------! + + + + !----- Find es00, which is a constant. ----------------------------------------------! + es00 = p00 * rtot / (ep+rtot) + !------------------------------------------------------------------------------------! + + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + ! 'NEWTON: it=',itn,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funnow & + ! ,'deriv=',deriv + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + converged = abs(tlcla-tlclz) < toler * tlclz + if (funnow == 0.) then + tlcl = tlclz + funz = funnow + converged = .true. + exit newloop + elseif (converged) then + tlcl = 0.5*(tlcla+tlclz) + funz = funnow + exit newloop + end if + end do newloop + + !------------------------------------------------------------------------------------! + ! If I reached this point then it's because Newton's method failed. Using bisec- ! + ! tion instead. ! + !------------------------------------------------------------------------------------! + if (.not. converged) then + !----- Set funz, and check whether funa and funz already have opposite sign. -----! + funz = funnow + zside=.true. + if (funa*funnow > 0.) then + !----- We fix funa, and try a funz that will work as 2nd guess ----------------! + if (abs(funz-funa) < toler*tlcla) then + delta = 100.*toler*tlcla + else + delta = max(abs(funa*(tlclz-tlcla)/(funz-funa)),100.*toler*tlcla) + end if + tlclz = tlcla + delta + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + ! '2NGGSS: tt=',itb,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funz & + ! ,'delta=',delta + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + zside = funa*funz < 0. + if (zside) exit zgssloop + end do zgssloop + if (.not. zside) then + write (unit=*,fmt='(a)') ' No second guess for you...' + write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theiv =',theiv ,'rtot =',rtot + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'pres =',pres ,'pvap =',pvap + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theta =',theta ,'delta =',delta + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlcla =',tlcla ,'funa =',funa + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlclz =',tlclz ,'funz =',funz + call fatal_error('Failed finding the second guess for regula falsi' & + ,'thetaeiv2thil','therm_lib.f90') + end if + end if + !---- Continue iterative method. -------------------------------------------------! + fpoloop: do itb=itn+1,maxfpo + + !----- Update the guess. ------------------------------------------------------! + tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) + + !----- Updating function evaluation -------------------------------------------! + pvap = eslif(tlcl,frozen) + theta = tlcl * (es00/pvap)**rocp + funnow = thetaeivs(theta,tlcl,rtot,0.,0.) - theiv + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=36,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + ! 'ANSWER: itb=',itn,'tlcl=',tlcl-t00,'eslcl=',0.01*pvap & + ! ,'thil=',thetaeiv2thil,'funa=',funa,'funz=',funz + !write (unit=36,fmt='(a)') '-------------------------------------------------------' + !write (unit=36,fmt='(a)') ' ' + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + else + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + write (unit=*,fmt='(a)') ' THEIV2THIL failed!' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Input: ' + write (unit=*,fmt='(a,1x,f12.5)') ' THEIV [ K]:',theiv + write (unit=*,fmt='(a,1x,f12.5)') ' PRES [ Pa]:',pres * 100. + write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1000.*rtot + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Output: ' + write (unit=*,fmt='(a,1x,i12)') ' ITERATIONS :',itb + write (unit=*,fmt='(a,1x,f12.5)') ' PVAP [ hPa]:',pvap + write (unit=*,fmt='(a,1x,f12.5)') ' THETA [ K]:',theta + write (unit=*,fmt='(a,1x,f12.5)') ' TLCL [ °C]:',tlcl-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' TLCLA [ °C]:',tlcla-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' TLCLZ [ °C]:',tlclz-t00 + write (unit=*,fmt='(a,1x,es12.5)') ' FUNA [ K]:',funa + write (unit=*,fmt='(a,1x,es12.5)') ' FUNZ [ K]:',funz + write (unit=*,fmt='(a,1x,es12.5)') ' DERIV [ ---]:',deriv + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_A [ ---]:',abs(tlcl-tlcla)/tlcl + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_Z [ ---]:',abs(tlcl-tlclz)/tlcl + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + + call fatal_error('TLCL didn''t converge, qgave up!' & + ,'thetaeiv2thil','therm_lib.f90') + end if + + return + end function thetaeiv2thil + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This subroutine converts saturated ice-vapour equivalent potential temperature ! + ! into temperature, given pressure in Pa, and theta_es in Kelvin. It also returns the ! + ! potential temperature in Kelvin, and saturation vapour mixing ratio in kg/kg. As ! + ! usual, we seek T using Newton's method as a starting point, and if it fails, we fall ! + ! back to the modified regula falsi (Illinois method). ! + ! ! + ! OBS: In case you want to ignore ice, send useice as false. The default is to consider ! + ! when level >= 3 and to ignore otherwise. ! + !---------------------------------------------------------------------------------------! + subroutine thetaeivs2temp(theivs,pres,theta,temp,rsat,useice) + use consts_coms, only : cpdry & ! intent(in) + , ep & ! intent(in) + , p00 & ! intent(in) + , rocp & ! intent(in) + , t00 ! ! intent(in) + implicit none + !----- Arguments --------------------------------------------------------------------! + real(kind=4), intent(in) :: theivs ! Sat. thetae_iv [ K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(out) :: theta ! Potential temperature [ K] + real(kind=4), intent(out) :: temp ! Temperature [ K] + real(kind=4), intent(out) :: rsat ! Saturation mixing ratio [ kg/kg] + logical , intent(in) , optional :: useice ! May use ice thermodyn. [ T|F] + !----- Local variables, with other thermodynamic properties -------------------------! + real(kind=4) :: exnernormi ! 1./ (Norm. Exner func.) [ ---] + logical :: frozen ! Will use ice thermodyn. [ T|F] + !----- Local variables for iterative method -----------------------------------------! + real(kind=4) :: deriv ! Function derivative + real(kind=4) :: funnow ! Current function evaluation + real(kind=4) :: funa ! Smallest guess function + real(kind=4) :: funz ! Largest guess function + real(kind=4) :: tempa ! Smallest guess (Newton: previous) + real(kind=4) :: tempz ! Largest guess (Newton: new) + real(kind=4) :: delta ! Aux. variable for 2nd guess. + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + logical :: converged ! Convergence handle + logical :: zside ! Flag for side check. + !------------------------------------------------------------------------------------! + + + !----- Set up the ice check, in case useice is not present. -------------------------! + if (present(useice)) then + frozen = useice + else + frozen = bulk_on + end if + !------------------------------------------------------------------------------------! + + + + !----- Finding the inverse of normalised Exner, which is constant in this routine ---! + exnernormi = (p00 /pres) ** rocp + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! The 1st. guess, no idea, guess 0°C. ! + !------------------------------------------------------------------------------------! + tempz = t00 + theta = tempz * exnernormi + rsat = rslif(pres,tempz,frozen) + funnow = thetaeivs(theta,tempz,rsat,0.,0.) + deriv = dthetaeivs_dt(funnow,tempz,pres,rsat,frozen) + funnow = funnow - theivs + !------------------------------------------------------------------------------------! + + + !----- Copy here just in case Newton is aborted at the 1st guess. -------------------! + tempa = tempz + funa = funnow + !------------------------------------------------------------------------------------! + + converged = .false. + !----- Newton's method loop. --------------------------------------------------------! + newloop: do itn=1,maxfpo/6 + if (abs(deriv) < toler) exit newloop !----- Too dangerous, skip to bisection -----! + !----- Updating guesses ----------------------------------------------------------! + tempa = tempz + funa = funnow + + tempz = tempa - funnow/deriv + theta = tempz * exnernormi + rsat = rslif(pres,tempz,frozen) + funnow = thetaeivs(theta,tempz,rsat,0.,0.) + deriv = dthetaeivs_dt(funnow,tempz,pres,rsat,frozen) + funnow = funnow - theivs + + converged = abs(tempa-tempz) < toler*tempz + if (funnow == 0.) then + converged =.true. + temp = tempz + exit newloop + elseif (converged) then + temp = 0.5*(tempa+tempz) + exit newloop + end if + end do newloop + + !------------------------------------------------------------------------------------! + ! If we have reached this point then it's because Newton's method failed. Use ! + ! bisection instead. ! + !------------------------------------------------------------------------------------! + if (.not. converged) then + !----- Set funz, and check whether funa and funz already have opposite sign. -----! + funz = funnow + zside = .false. + !---------------------------------------------------------------------------------! + + if (funa*funnow > 0.) then + !----- We fix funa, and try a funz that will work as 2nd guess ----------------! + if (abs(funz-funa) < toler*tempa) then + delta = 100.*toler*tempa + else + delta = max(abs(funa*(tempz-tempa)/(funz-funa)),100.*toler*tempa) + end if + !------------------------------------------------------------------------------! + + tempz = tempa + delta + zgssloop: do itb=1,maxfpo + !----- So this will be +1 -1 +2 -2 etc. ------------------------------------! + tempz = tempz + real((-1)**itb * (itb+3)/2) * delta + theta = tempz * exnernormi + rsat = rslif(pres,tempz,frozen) + funz = thetaeivs(theta,tempz,rsat,0.,0.) - theivs + zside = funa*funz < 0. + if (zside) exit zgssloop + end do zgssloop + if (.not. zside) then + call fatal_error('Failed finding the second guess for regula falsi' & + ,'thetaes2temp','therm_lib.f90') + end if + end if + !---- Continue iterative method --------------------------------------------------! + fpoloop: do itb=itn+1,maxfpo + if (abs(funz-funa) < toler*tempa) then + temp = 0.5*(tempa+tempz) + else + temp = (funz*tempa-funa*tempz)/(funz-funa) + end if + theta = temp * exnernormi + rsat = rslif(pres,temp,frozen) + funnow = thetaeivs(theta,temp,rsat,0.,0.) - theivs + + !------------------------------------------------------------------------------! + ! Checking for convergence. If it did, return, we found the solution. ! + ! Otherwise, constrain the guesses. ! + !------------------------------------------------------------------------------! + converged = abs(temp-tempa) < toler*temp + if (converged) then + exit fpoloop + elseif (funnow*funa < 0.) then + tempz = temp + funz = funnow + !----- If we are updating zside again, modify aside (Illinois method) ------! + if (zside) funa=funa * 0.5 + !----- We just updated zside, setting zside to true. -----------------------! + zside = .true. + else + tempa = temp + funa = funnow + !----- If we are updating aside again, modify zside (Illinois method) ------! + if (.not. zside) funz = funz * 0.5 + !----- We just updated aside, setting zside to false -----------------------! + zside = .false. + end if + end do fpoloop end if - - - !----- Finding the derivative. Depending on the temperature, use different eqn. -----! - if (tlcl > ttripoli) then - dthetaeiv_dtlcl = theiv * (1. - rocp*tlcl*desdtlcl/eslcl - aklv*rtot/tlcl) / tlcl + if (converged) then + !----- Compute theta and rsat with temp just for consistency ---------------------! + theta = temp * exnernormi + rsat = rslif(pres,temp,frozen) else - dthetaeiv_dtlcl = theiv * (1. - rocp*tlcl*desdtlcl/eslcl ) / tlcl + call fatal_error('Temperature didn''t converge, I gave up!' & + ,'thetaes2temp','therm_lib.f90') end if return - end function dthetaeiv_dtlcl + end subroutine thetaeivs2temp !=======================================================================================! !=======================================================================================! @@ -2201,351 +3978,348 @@ end function dthetaeiv_dtlcl !=======================================================================================! !=======================================================================================! - ! This function computes the saturation ice-vapour equivalent potential temperature ! - ! from theta_il and the total mixing ratio (split into saturated vapour plus liquid and ! - ! ice. This is equivalent to the equivalent potential temperature considering also the ! - ! effects of fusion/melting/sublimation, and it is done separatedly from the regular ! - ! thetae_iv because it doesn't require iterations. ! + ! This subroutine finds the lifting condensation level given the ice-liquid ! + ! potential temperature in Kelvin, temperature in Kelvin, the pressure in Pascal, and ! + ! the mixing ratio in kg/kg. The output will give the LCL temperature and pressure, and ! + ! the thickness of the layer between the initial point and the LCL. ! ! ! ! References: ! - ! Tripoli, J. T.; and Cotton, W.R., 1981: The use of ice-liquid water potential tem- ! - ! perature as a thermodynamic variable in deep atmospheric models. Mon. Wea. ! + ! Tripoli, J. T.; and Cotton, W.R., 1981: The use of ice-liquid water potential ! + ! temperature as a thermodynamic variable in deep atmospheric models. Mon. Wea. ! ! Rev., v. 109, 1094-1102. (TC81) ! + ! Bolton, D., 1980: The computation of the equivalent potential temperature. Mon. ! + ! Wea. Rev., v. 108, 1046-1053. (BO80) ! ! ! ! Some algebra was needed to find this equation, essentially combining (TC81-26) and ! ! (TC81-27), and the conservation of total water (TC81-16). It assumes that the divi- ! ! sion between the three phases is already taken care of. ! - !---------------------------------------------------------------------------------------! - real function thetaeivs(thil,temp,rsat,rliq,rice) - use consts_coms, only : aklv, ttripoli - implicit none - real, intent(in) :: thil ! Theta_il, ice-liquid water potential temp. [ K] - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: rsat ! Saturation water vapour mixing ratio [ kg/kg] - real, intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] - real, intent(in) :: rice ! Ice mixing ratio [ kg/kg] - - real :: rtots ! Saturated mixing ratio [ K] - - rtots = rsat+rliq+rice - - thetaeivs = thil * exp ( aklv * rtots / max(temp,ttripoli)) - - return - end function thetaeivs - !=======================================================================================! - !=======================================================================================! - - - - - - - !=======================================================================================! - !=======================================================================================! - ! This function computes the derivative of saturation ice-vapour equivalent ! - ! potential temperature, based on the expression used to compute the saturation ! - ! ice-vapour equivalent potential temperature (function thetaeivs). ! + ! Iterative procedure is needed, and here we iterate looking for T(LCL). Theta_il ! + ! can be rewritten in terms of T(LCL) only, and once we know this thetae_iv becomes ! + ! straightforward. T(LCL) will be found using Newton's method, and in the unlikely ! + ! event it fails,we will fall back to the modified regula falsi (Illinois method). ! ! ! - ! IMPORTANT!!! This CANNOT BE USED to compute d(Thetae_iv)/d(T_LCL), because here ! - ! we assume that temperature and pressure are known and constants, and ! - ! that the mixing ratio is a function of temperature. In case you want ! - ! d(Thetae_iv)/d(T_LCL), use the dthetaeiv_dtlcl function instead. ! + ! Important remarks: ! + ! 1. TLCL and PLCL are the actual TLCL and PLCL, so in case condensation exists, they ! + ! will be larger than the actual temperature and pressure (because one would go down ! + ! to reach the equilibrium); ! + ! 2. DZLCL WILL BE SET TO ZERO in case the LCL is beneath the starting level. So in ! + ! case you want to force TLCL <= TEMP and PLCL <= PRES, you can use this variable ! + ! to run the saturation check afterwards. DON'T CHANGE PLCL and TLCL here, they will ! + ! be used for conversions between theta_il and thetae_iv as they are defined here. ! + ! 3. In case you don't want ice, simply pass useice=.false.. Otherwise let the model ! + ! decide by itself based on the LEVEL variable. ! !---------------------------------------------------------------------------------------! - real function dthetaeivs_dt(theivs,temp,pres,rsat,useice) - use consts_coms, only : aklv,alvl,ttripoli,htripolii + subroutine lcl_il(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl,useice) + use consts_coms, only : cpog & ! intent(in) + , ep & ! intent(in) + , p00 & ! intent(in) + , rocp & ! intent(in) + , t3ple & ! intent(in) + , t00 ! ! intent(in) implicit none - !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: theivs ! Sat. ice-vap. eq. pot. temp. [ K] - real , intent(in) :: temp ! Temperature [ K] - real , intent(in) :: pres ! Pressure [ Pa] - real , intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] - logical, intent(in), optional :: useice ! Flag for considering ice [ T|F] - !----- Local variables --------------------------------------------------------------! - real :: drsdt ! Saturated mixing ratio deriv. [kg/kg/K] + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: thil ! Ice liquid pot. temp. (*)[ K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + real(kind=4), intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] + real(kind=4), intent(out) :: tlcl ! LCL temperature [ K] + real(kind=4), intent(out) :: plcl ! LCL pressure [ Pa] + real(kind=4), intent(out) :: dzlcl ! Sub-LCL layer thickness [ m] + !------------------------------------------------------------------------------------! + ! (*) This is the most general variable. Thil is exactly theta for no condensation ! + ! condition, and it is the liquid potential temperature if no ice is present. ! + !------------------------------------------------------------------------------------! + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in) , optional :: useice ! May use ice thermodyn.? [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: pvap ! Sat. vapour pressure + real(kind=4) :: deriv ! Function derivative + real(kind=4) :: funnow ! Current function evaluation + real(kind=4) :: funa ! Smallest guess function + real(kind=4) :: funz ! Largest guess function + real(kind=4) :: tlcla ! Smallest guess (Newton: previous) + real(kind=4) :: tlclz ! Largest guess (Newton: new) + real(kind=4) :: es00 ! Defined as p00*rt/(epsilon + rt) + real(kind=4) :: delta ! Aux. variable for bisection + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + logical :: converged ! Convergence flag + logical :: zside ! Flag to check sides + logical :: frozen ! Will use ice thermodyn. [ T|F] !------------------------------------------------------------------------------------! - !----- Finding the derivative of rs with temperature --------------------------------! + !------------------------------------------------------------------------------------! + ! Check whether ice thermodynamics is the way to go. ! + !------------------------------------------------------------------------------------! if (present(useice)) then - drsdt = rslifp(pres,temp,useice) - else - drsdt = rslifp(pres,temp) - end if - - - !----- Finding the derivative. Depending on the temperature, use different eqn. -----! - if (temp > ttripoli) then - dthetaeivs_dt = theivs * (1. + aklv * (drsdt*temp-rsat)/temp ) / temp - else - dthetaeivs_dt = theivs * (1. + alvl * drsdt * temp * htripolii ) / temp + frozen = useice + else + frozen = bulk_on end if + !------------------------------------------------------------------------------------! - - return - end function dthetaeivs_dt - !=======================================================================================! - !=======================================================================================! - - - - + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & ! 'NEWTON: it=',itn,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funnow & ! ,'deriv=',deriv !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - converged = abs(tlcla-tlclz) < toler * tlclz - if (funnow == 0.) then - tlcl = tlclz + !---------------------------------------------------------------------------------! + ! Check for convergence. ! + !---------------------------------------------------------------------------------! + converged = abs(tlcla-tlclz) < toler*tlclz + if (converged) then + !----- Guesses are almost identical, average them. ----------------------------! + tlcl = 0.5*(tlcla+tlclz) funz = funnow - converged = .true. exit newloop - elseif (converged) then - tlcl = 0.5*(tlcla+tlclz) + !------------------------------------------------------------------------------! + elseif (funnow == 0.) then + !----- We've hit the answer by luck, copy the answer. -------------------------! + tlcl = tlclz funz = funnow + converged = .true. exit newloop + !------------------------------------------------------------------------------! end if end do newloop + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! Check whether Newton's method has converged. ! !------------------------------------------------------------------------------------! if (.not. converged) then - !----- Set funz, and check whether funa and funz already have opposite sign. -----! - funz = funnow - zside=.true. - if (funa*funnow > 0.) then + !---------------------------------------------------------------------------------! + ! Newton's method has failed. We use regula falsi instead. First, we must ! + ! find two guesses whose function evaluations have opposite signs. ! + !---------------------------------------------------------------------------------! + if (funa*funnow < 0. ) then + !----- We already have two good guesses. --------------------------------------! + funz = funnow + zside = .true. + !------------------------------------------------------------------------------! + else + !------------------------------------------------------------------------------! + ! We need to find another guess with opposite sign. ! + !------------------------------------------------------------------------------! + !----- We fix funa, and try a funz that will work as 2nd guess ----------------! - if (abs(funz-funa) < toler*tlcla) then + if (abs(funnow-funa) < toler*tlcla) then delta = 100.*toler*tlcla else - delta = max(abs(funa*(tlclz-tlcla)/(funz-funa)),100.*toler*tlcla) + delta = max(abs(funa*(tlclz-tlcla)/(funnow-funa)),100.*toler*tlcla) end if tlclz = tlcla + delta + !------------------------------------------------------------------------------! !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & ! '2NGGSS: tt=',itb,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funz & ! ,'delta=',delta !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - - zside = funa*funz < 0 + zside = funa*funz < 0.0 if (zside) exit zgssloop end do zgssloop if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theiv =',theiv ,'rtot =',rtot - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'pres =',pres ,'pvap =',pvap - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theta =',theta ,'delta =',delta - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlcla =',tlcla ,'funa =',funa - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlclz =',tlclz ,'funz =',funz + write (unit=*,fmt='(a)') ' ====== No second guess for you... ======' + write (unit=*,fmt='(a)') ' + INPUT variables: ' + write (unit=*,fmt='(a,1x,es14.7)') 'THIL =',thil + write (unit=*,fmt='(a,1x,es14.7)') 'TEMP =',temp + write (unit=*,fmt='(a,1x,es14.7)') 'PRES =',pres + write (unit=*,fmt='(a,1x,es14.7)') 'RTOT =',rtot + write (unit=*,fmt='(a,1x,es14.7)') 'RVAP =',rvap + write (unit=*,fmt='(a)') ' ============ Failed guess... ===========' + write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLA =',tlcla,'FUNA =',funa + write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLZ =',tlclz,'FUNC =',funz + write (unit=*,fmt='(2(a,1x,es14.7))') 'DELTA =',delta,'FUNN =',funnow call fatal_error('Failed finding the second guess for regula falsi' & - ,'thetaeiv2thil','therm_lib.f90') + ,'lcl_il','therm_lib.f90') end if end if - !---- Continue iterative method --------------------------------------------------! - fpoloop: do itb=itn+1,maxfpo + !---------------------------------------------------------------------------------! - !----- Updating the guess -----------------------------------------------------! - tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) - !----- Updating function evaluation -------------------------------------------! - pvap = eslif(tlcl,brrr_cold) - theta = tlcl * (es00/pvap)**rocp - funnow = thetaeivs(theta,tlcl,rtot,0.,0.) - theiv + !---------------------------------------------------------------------------------! + ! We have the guesses, solve the regula falsi method. ! + !---------------------------------------------------------------------------------! + fpoloop: do itb=itn+1,maxfpo + !----- Update guess and function evaluation. ----------------------------------! + tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) + pvap = eslif(tlcl,frozen) + funnow = tlcl * (es00/pvap)**rocp - thil + !------------------------------------------------------------------------------! !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=36,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + !write (unit=21,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),3(a,1x,es11.4,1x))') & ! 'ANSWER: itb=',itn,'tlcl=',tlcl-t00,'eslcl=',0.01*pvap & - ! ,'thil=',thetaeiv2thil,'funa=',funa,'funz=',funz - !write (unit=36,fmt='(a)') '-------------------------------------------------------' - !write (unit=36,fmt='(a)') ' ' + ! ,'dzlcl=',dzlcl,'plcl=',plcl*0.01,'funa=',funa,'funz=',funz + !write (unit=21,fmt='(a)') '-------------------------------------------------------' + !write (unit=21,fmt='(a)') ' ' !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! else - write (unit=*,fmt='(60a1)') ('-',ii=1,60) - write (unit=*,fmt='(a)') ' THEIV2THIL failed!' - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' -> Input: ' - write (unit=*,fmt='(a,1x,f12.5)') ' THEIV [ K]:',theiv - write (unit=*,fmt='(a,1x,f12.5)') ' PRES [ Pa]:',pres * 100. - write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1000.*rtot - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' -> Output: ' - write (unit=*,fmt='(a,1x,i12)') ' ITERATIONS :',itb - write (unit=*,fmt='(a,1x,f12.5)') ' PVAP [ hPa]:',pvap - write (unit=*,fmt='(a,1x,f12.5)') ' THETA [ K]:',theta - write (unit=*,fmt='(a,1x,f12.5)') ' TLCL [ °C]:',tlcl-t00 - write (unit=*,fmt='(a,1x,f12.5)') ' TLCLA [ °C]:',tlcla-t00 - write (unit=*,fmt='(a,1x,f12.5)') ' TLCLZ [ °C]:',tlclz-t00 - write (unit=*,fmt='(a,1x,es12.5)') ' FUNA [ K]:',funa - write (unit=*,fmt='(a,1x,es12.5)') ' FUNZ [ K]:',funz - write (unit=*,fmt='(a,1x,es12.5)') ' DERIV [ ---]:',deriv - write (unit=*,fmt='(a,1x,es12.5)') ' ERR_A [ ---]:',abs(tlcl-tlcla)/tlcl - write (unit=*,fmt='(a,1x,es12.5)') ' ERR_Z [ ---]:',abs(tlcl-tlclz)/tlcl - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(60a1)') ('-',ii=1,60) - - call fatal_error('TLCL didn''t converge, gave up!' & - ,'thetaeiv2thil','therm_lib.f90') + write (unit=*,fmt='(a)') '-------------------------------------------------------' + write (unit=*,fmt='(a)') ' LCL Temperature didn''t converge!!!' + write (unit=*,fmt='(a,1x,i5,1x,a)') ' I gave up, after',maxfpo,'iterations...' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input values.' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a,1x,f12.4)' ) 'theta_il [ K] =',thil + write (unit=*,fmt='(a,1x,f12.4)' ) 'Pressure [ hPa] =',0.01*pres + write (unit=*,fmt='(a,1x,f12.4)' ) 'Temperature [ °C] =',temp-t00 + write (unit=*,fmt='(a,1x,f12.4)' ) 'rtot [ g/kg] =',1000.*rtot + write (unit=*,fmt='(a,1x,f12.4)' ) 'rvap [ g/kg] =',1000.*rvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Last iteration outcome.' + write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcla [ °C] =',tlcla-t00 + write (unit=*,fmt='(a,1x,f12.4)' ) 'tlclz [ °C] =',tlclz-t00 + write (unit=*,fmt='(a,1x,f12.4)' ) 'fun [ K] =',funnow + write (unit=*,fmt='(a,1x,f12.4)' ) 'funa [ K] =',funa + write (unit=*,fmt='(a,1x,f12.4)' ) 'funz [ K] =',funz + write (unit=*,fmt='(a,1x,f12.4)' ) 'deriv [ ----] =',deriv + write (unit=*,fmt='(a,1x,es12.4)') 'toler [ ----] =',toler + write (unit=*,fmt='(a,1x,es12.4)') 'error [ ----] =' & + ,abs(tlclz-tlcla)/tlclz + write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcl [ °C] =',tlcl + call fatal_error('TLCL didn''t converge, gave up!','lcl_il','therm_lib.f90') end if - return - end function thetaeiv2thil + end subroutine lcl_il !=======================================================================================! !=======================================================================================! @@ -2556,137 +4330,317 @@ end function thetaeiv2thil !=======================================================================================! !=======================================================================================! - ! This subroutine converts saturated ice-vapour equivalent potential temperature ! - ! into temperature, given pressure in Pa, and theta_es in Kelvin. It also returns the ! - ! potential temperature in Kelvin, and saturation vapour mixing ratio in kg/kg. As ! - ! usual, we seek T using Newton's method as a starting point, and if it fails, we fall ! - ! back to the modified regula falsi (Illinois method). ! - ! ! - ! OBS: In case you want to ignore ice, send useice as false. The default is to consider ! - ! when level >= 3 and to ignore otherwise. ! + ! This subroutine computes a consistent set of temperature and condensated phases ! + ! mixing ratio for a given theta_il, Exner function, and total mixing ratio. This is ! + ! very similar to the function thil2temp, except that now we don't know rliq and rice, ! + ! and for this reason they also become functions of temperature, since they are defined ! + ! as rtot-rsat(T,p), remembering that rtot and p are known. If the air is not ! + ! saturated, we rather use the fact that theta_il = theta and skip the hassle. ! + ! Otherwise, we use iterative methods. We will always try Newton's method, since it ! + ! converges fast. The caveat is that Newton may fail, and it actually does fail very ! + ! close to the triple point, because the saturation vapour pressure function has a ! + ! "kink" at the triple point (continuous, but not differentiable). If that's the case, ! + ! then we fall back to a modified regula falsi (Illinois) method, which is a mix of ! + ! secant and bisection and will converge. ! !---------------------------------------------------------------------------------------! - subroutine thetaeivs2temp(theivs,pres,theta,temp,rsat,useice) - use consts_coms, only : alvl,cp,ep,p00,rocp,ttripoli,t00 + subroutine thil2tqall(thil,exner,pres,rtot,rliq,rice,temp,rvap,rsat) + use consts_coms, only : cpdry & ! intent(in) + , cpdryi & ! intent(in) + , t00 & ! intent(in) + , toodry & ! intent(in) + , t3ple ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: theivs ! Sat. thetae_iv [ K] - real , intent(in) :: pres ! Pressure [ Pa] - real , intent(out) :: theta ! Potential temperature [ K] - real , intent(out) :: temp ! Temperature [ K] - real , intent(out) :: rsat ! Saturation mixing ratio [ kg/kg] - logical, intent(in) , optional :: useice ! Flag for considering ice [ T|F] - !----- Local variables, with other thermodynamic properties -------------------------! - real :: exnernormi ! 1./ (Norm. Exner function) [ ---] - logical :: brrr_cold ! Flag for ice thermo [ T|F] - !----- Local variables for iterative method -----------------------------------------! - real :: deriv ! Function derivative - real :: funnow ! Function for which we seek a root. - real :: funa ! Smallest guess function - real :: funz ! Largest guess function - real :: tempa ! Smallest guess (or previous in Newton) - real :: tempz ! Largest guess (or new in Newton) - real :: delta ! Aux. variable for 2nd guess finding. - integer :: itn,itb ! Iteration counters - logical :: converged ! Convergence handle - logical :: zside ! Aux. flag, check sides (Regula Falsi) - !------------------------------------------------------------------------------------! - - !----- Setting up the ice check, in case useice is not present. ---------------------! - if (present(useice)) then - brrr_cold = useice - else - brrr_cold = bulk_on + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: thil ! Ice-liquid water potential temp. [ K] + real(kind=4), intent(in) :: exner ! Exner function [J/kg/K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + real(kind=4), intent(out) :: rliq ! Liquid water mixing ratio [ kg/kg] + real(kind=4), intent(out) :: rice ! Ice mixing ratio [ kg/kg] + real(kind=4), intent(inout) :: temp ! Temperature [ K] + real(kind=4), intent(out) :: rvap ! Water vapour mixing ratio [ kg/kg] + real(kind=4), intent(out) :: rsat ! Sat. water vapour mixing ratio [ kg/kg] + !----- Local variables --------------------------------------------------------------! + real(kind=4) :: tempa ! Lower bound for regula falsi iteration + real(kind=4) :: tempz ! Upper bound for regula falsi iteration + real(kind=4) :: t1stguess ! Book keeping temperature 1st guess + real(kind=4) :: fun1st ! Book keeping 1st guess function + real(kind=4) :: funa ! Function evaluation at tempa + real(kind=4) :: funz ! Function evaluation at tempz + real(kind=4) :: funnow ! Function at this iteration. + real(kind=4) :: delta ! Aux. var in case we need regula falsi. + real(kind=4) :: deriv ! Derivative of this function. + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + integer :: ii ! Iteration counter + logical :: converged ! Convergence handle + logical :: zside ! Aux. Flag, for two purposes: + ! 1. Found a 2nd guess for regula falsi. + ! 2. I retained the "zside" (T/F) + !------------------------------------------------------------------------------------! + + t1stguess = temp + + !------------------------------------------------------------------------------------! + ! First check: try to find temperature assuming sub-saturation and check if ! + ! this is the case. If it is, then there is no need to go through the iterative ! + ! loop. ! + !------------------------------------------------------------------------------------! + tempz = cpdryi * thil * exner + rsat = max(toodry,rslif(pres,tempz)) + if (tempz >= t3ple) then + rliq = max(0.,rtot-rsat) + rice = 0. + else + rice = max(0.,rtot-rsat) + rliq = 0. end if - - !----- Finding the inverse of normalised Exner, which is constant in this routine ---! - exnernormi = (p00 /pres) ** rocp + rvap = rtot-rliq-rice + !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! - ! The 1st. guess, no idea, guess 0°C. ! + ! If rtot < rsat, this is not saturated, we can leave the subroutine and bypass ! + ! the iterative part. ! !------------------------------------------------------------------------------------! - tempz = t00 - theta = tempz * exnernormi - rsat = rslif(pres,tempz,brrr_cold) - funnow = thetaeivs(theta,tempz,rsat,0.,0.) - deriv = dthetaeivs_dt(funnow,tempz,pres,rsat,brrr_cold) - funnow = funnow - theivs + if (rtot < rsat) then + temp = tempz + return + end if - !----- Saving here just in case Newton is aborted at the 1st guess ------------------! - tempa = tempz - funa = funnow + !------------------------------------------------------------------------------------! + ! If not, then use the temperature the user gave as first guess and solve ! + ! iteratively. We use the user instead of what we just found because if the air is ! + ! saturated, then this can be too far off which may be bad for Newton's method. ! + !------------------------------------------------------------------------------------! + tempz = temp + rsat = max(toodry,rslif(pres,tempz)) + if (tempz >= t3ple) then + rliq = max(0.,rtot-rsat) + rice = 0. + else + rice = max(0.,rtot-rsat) + rliq = 0. + end if + rvap = rtot-rliq-rice - converged = .false. - !----- Looping ----------------------------------------------------------------------! + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>= t3ple) then + rliq = max(0.,rtot-rsat) + rice = 0. + else + rice = max(0.,rtot-rsat) + rliq = 0. + end if + rvap = rtot-rliq-rice + + !----- Updating the function -----------------------------------------------------! + funnow = theta_iceliq(exner,tempz,rliq,rice) + !----- Updating the derivative. --------------------------------------------------! + deriv = dthetail_dt(.false.,funnow,exner,pres,tempz,rliq,rice) + funnow = funnow - thil + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=46,fmt='(a,1x,i5,1x,6(a,1x,f11.4,1x),a,1x,es11.4,1x)') & + ! 'NEWTON: it=',itn,'temp=',tempz-t00,'rsat=',1000.*rsat,'rliq=',1000.*rliq & + ! ,'rice=',1000.*rice,'rvap=',1000.*rvap,'fun=',funnow,'deriv=',deriv + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + converged = abs(tempa-tempz) < toler*tempz + !---------------------------------------------------------------------------------! + ! Convergence. The temperature will be the mid-point between tempa and tempz. ! + ! Fix the mixing ratios and return. But first check for converged due to luck. If ! + ! the guess gives a root, then that's it. It looks unlikely, but it actually ! + ! happens sometimes and if not checked it becomes a singularity. ! + !---------------------------------------------------------------------------------! if (funnow == 0.) then - converged =.true. temp = tempz + converged = .true. exit newloop elseif (converged) then - temp = 0.5*(tempa+tempz) + temp = 0.5 * (tempa+tempz) + rsat = max(toodry,rslif(pres,temp)) + if (temp >= t3ple) then + rliq = max(0.,rtot-rsat) + rice = 0. + else + rice = max(0.,rtot-rsat) + rliq = 0. + end if + rvap = rtot-rliq-rice exit newloop end if - end do newloop + end do newloop !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! - !------------------------------------------------------------------------------------! + + !----- For debugging only -----------------------------------------------------------! + itb = itn+1 + if (.not. converged) then - !----- Set funz, and check whether funa and funz already have opposite sign. -----! - funz = funnow - zside = .false. - if (funa*funnow > 0.) then - !----- We fix funa, and try a funz that will work as 2nd guess ----------------! - if (abs(funz-funa) < toler*tempa) then + !---------------------------------------------------------------------------------! + ! If I reach this point, then it means that Newton's method failed finding the ! + ! equilibrium, so we are going to use the regula falsi instead. If Newton's ! + ! method didn't converge, we use tempa as one guess and now we seek a tempz with ! + ! opposite sign. ! + !---------------------------------------------------------------------------------! + !----- Check funa and funnow have opposite signs. If so, we are ready to go ------! + if (funa*funnow < 0.0) then + funz = funnow + zside = .true. + !----- Otherwise, checking whether the 1st guess had opposite sign. --------------! + elseif (funa*fun1st < 0.0) then + funz = fun1st + zside = .true. + !---------------------------------------------------------------------------------! + ! Looking for a guess. Extrapolate funa linearly, trying to get the -funa. We ! + ! don't need it to be funa, just with the opposite sign. If that's not enough, ! + ! we keep going further... Force the guesses to be at least 1K apart ! + !---------------------------------------------------------------------------------! + else + if (abs(funnow-funa) < 100.*toler*tempa) then delta = 100.*toler*tempa else - delta = max(abs(funa*(tempz-tempa)/(funz-funa)),100.*toler*tempa) + delta = max(abs(funa)*abs((tempz-tempa)/(funnow-funa)),100.*toler*tempa) end if tempz = tempa + delta + funz = funa + !----- Just to enter at least once. The 1st time tempz=tempa-2*delta ----------! + zside = .false. zgssloop: do itb=1,maxfpo - !----- So this will be +1 -1 +2 -2 etc. ------------------------------------! - tempz = tempz + real((-1)**itb * (itb+3)/2) * delta - theta = tempz * exnernormi - rsat = rslif(pres,tempz,brrr_cold) - funz = thetaeivs(theta,tempz,rsat,0.,0.) - theivs - zside = funa*funz < 0 - if (zside) exit zgssloop + tempz = tempa + real((-1)**itb * (itb+3)/2) * delta + rsat = max(toodry,rslif(pres,tempz)) + if (tempz >= t3ple) then + rliq = max(0.,rtot-rsat) + rice = 0. + else + rice = max(0.,rtot-rsat) + rliq = 0. + end if + rvap = rtot-rliq-rice + funz = theta_iceliq(exner,tempz,rliq,rice) - thil + zside = funa*funz < 0.0 + if (zside) exit zgssloop end do zgssloop - if (.not. zside) & + if (.not. zside) then + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + write (unit=*,fmt='(a)') ' THIL2TQALL: NO SECOND GUESS FOR YOU!' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Input: ' + write (unit=*,fmt='(a,1x,f12.5)') ' THETA_IL [ K]:',thil + write (unit=*,fmt='(a,1x,f12.5)') ' PRESS [ hPa]:',0.01*pres + write (unit=*,fmt='(a,1x,f12.5)') ' EXNER [J/kg/K]:',exner + write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1000.*rtot + write (unit=*,fmt='(a,1x,f12.5)') ' T1ST [ degC]:',t1stguess-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPA [ degC]:',tempa-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPZ [ degC]:',tempz-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' FUNNOW [ K]:',funnow + write (unit=*,fmt='(a,1x,f12.5)') ' FUNA [ K]:',funa + write (unit=*,fmt='(a,1x,f12.5)') ' FUNZ [ K]:',funz + write (unit=*,fmt='(a,1x,f12.5)') ' DELTA [ K]:',delta + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + call fatal_error('Failed finding the second guess for regula falsi' & - ,'thetaes2temp','therm_lib.f90') + ,'thil2tqall','therm_lib.f90') + end if end if - !---- Continue iterative method --------------------------------------------------! - fpoloop: do itb=itn+1,maxfpo - if (abs(funz-funa) < toler*tempa) then - temp = 0.5*(tempa+tempz) + !---------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------! + ! Now we loop until convergence is achieved. One important thing to notice ! + ! is that Newton's method fail only when T is almost T3ple, which means that ice ! + ! and liquid should be present, and we are trying to find the saturation point ! + ! with all ice or all liquid. This will converge but the final answer will ! + ! contain significant error. To reduce it we redistribute the condensates between ! + ! ice and liquid conserving the total condensed mixing ratio. ! + !---------------------------------------------------------------------------------! + fpoloop: do itb=itn,maxfpo + temp = (funz*tempa-funa*tempz)/(funz-funa) + !----- Checking whether this guess will fall outside the range ----------------! + if (abs(temp-tempa) > abs(tempz-tempa) .or. & + abs(temp-tempz) > abs(tempz-tempa)) then + temp = 0.5*(tempa+tempz) + end if + !----- Distributing vapour into the three phases ------------------------------! + rsat = max(toodry,rslif(pres,temp)) + rvap = min(rtot,rsat) + if (temp >= t3ple) then + rliq = max(0.,rtot-rsat) + rice = 0. else - temp = (funz*tempa-funa*tempz)/(funz-funa) + rliq = 0. + rice = max(0.,rtot-rsat) end if - theta = temp * exnernormi - rsat = rslif(pres,temp,brrr_cold) - funnow = thetaeivs(theta,temp,rsat,0.,0.) - theivs + !----- Updating function ------------------------------------------------------! + funnow = theta_iceliq(exner,temp,rliq,rice) - thil + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> Input: ' + write (unit=*,fmt='(a,1x,f12.5)') ' THETA_IL [ K]:',thil + write (unit=*,fmt='(a,1x,f12.5)') ' EXNER [J/kg/K]:',exner + write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1000.*rtot + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Output: ' + write (unit=*,fmt='(a,1x,i12)') ' ITERATIONS :',itb + write (unit=*,fmt='(a,1x,f12.5)') ' TEMP [ °C]:',temp-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' RVAP [ g/kg]:',1000.*rvap + write (unit=*,fmt='(a,1x,f12.5)') ' RLIQ [ g/kg]:',1000.*rliq + write (unit=*,fmt='(a,1x,f12.5)') ' RICE [ g/kg]:',1000.*rice + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPA [ °C]:',tempa-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPZ [ °C]:',tempz-t00 + write (unit=*,fmt='(a,1x,es12.5)') ' FUNA [ K]:',funnow + write (unit=*,fmt='(a,1x,es12.5)') ' FUNZ [ K]:',funnow + write (unit=*,fmt='(a,1x,es12.5)') ' DERIV [ ---]:',deriv + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_A [ ---]:',abs(temp-tempa)/temp + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_Z [ ---]:',abs(temp-tempz)/temp + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + call fatal_error('Failed finding equilibrium, I gave up!','thil2tqall' & + ,'therm_lib.f90') + end if + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & - ! 'NEWTON: it=',itn,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funnow & - ! ,'deriv=',deriv - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !----- Go to bisection if the derivative is too flat (too dangerous...) ----------! + if (abs(deriv) < toler) exit newloop - !------------------------------------------------------------------------------! - ! Convergence may happen when we get close guesses. ! - !------------------------------------------------------------------------------! - converged = abs(tlcla-tlclz) < toler*tlclz - if (converged) then - tlcl = 0.5*(tlcla+tlclz) - funz = funnow - exit newloop - elseif (funnow == 0.) then - tlcl = tlclz - funz = funnow + tempz = tempa - funnow / deriv + + !----- Finding the mixing ratios associated with this guess ----------------------! + rsat = max(toodry,rslf(pres,tempz)) + rliq = max(0.,rtot-rsat) + rvap = rtot-rliq + + !----- Updating the function -----------------------------------------------------! + funnow = theta_iceliq(exner,tempz,rliq,0.) + !----- Updating the derivative. --------------------------------------------------! + deriv = dthetail_dt(.false.,funnow,exner,pres,tempz,rliq) + funnow = funnow - thil + + converged = abs(tempa-tempz) < toler*tempz + !---------------------------------------------------------------------------------! + ! Convergence. The temperature will be the mid-point between tempa and tempz. ! + ! Fix the mixing ratios and return. But first check for converged due to luck. If ! + ! the guess gives a root, then that's it. It looks unlikely, but it actually ! + ! happens sometimes and if not checked it becomes a singularity. ! + !---------------------------------------------------------------------------------! + if (funnow == 0.) then + temp = tempz converged = .true. exit newloop + elseif (converged) then + temp = 0.5 * (tempa+tempz) + rsat = max(toodry,rslf(pres,temp)) + rliq = max(0.,rtot-rsat) + rvap = rtot-rliq + exit newloop end if + !---------------------------------------------------------------------------------! end do newloop + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! if (.not. converged) then !---------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using re- ! - ! gula falsi instead. First, I need to find two guesses that give me functions ! - ! with opposite signs. If funa and funnow have opposite signs, then we are all ! - ! set. ! + ! If I reach this point, then it means that Newton's method failed finding the ! + ! equilibrium, so we are going to use the regula falsi instead. If Newton's ! + ! method didn't converge, we use tempa as one guess and now we seek a tempz with ! + ! opposite sign. ! !---------------------------------------------------------------------------------! - if (funa*funnow < 0. ) then - funz = funnow + !----- Check funa and funnow have opposite signs. If so, we are ready to go ------! + if (funa*funnow < 0.0) then + funz = funnow zside = .true. - !----- They have the same sign, seeking the other guess --------------------------! + !---------------------------------------------------------------------------------! + ! Looking for a guess. Extrapolate funa linearly, trying to get the -funa. We ! + ! don't need it to be funa, just with the opposite sign. If that's not enough, ! + ! we keep going further... Force the guesses to be at least 1K apart ! + !---------------------------------------------------------------------------------! else - - !----- We fix funa, and try a funz that will work as 2nd guess ----------------! - if (abs(funnow-funa) < toler*tlcla) then - delta = 100.*toler*tlcla + if (abs(funnow-funa) < toler*tempa) then + delta = 100.*toler*tempa else - delta = max(abs(funa*(tlclz-tlcla)/(funnow-funa)),100.*toler*tlcla) + delta = max(abs(funa*(tempz-tempa)/(funnow-funa)),100.*toler*tempa) end if - tlclz = tlcla + delta - - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & - ! '2NGGSS: tt=',itb,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funz & - ! ,'delta=',delta - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - zside = funa*funz < 0 + tempz = tempz + real((-1)**itb * (itb+3)/2) * delta + rsat = max(toodry,rslf(pres,tempz)) + rliq = max(0.,rtot-rsat) + rvap = rtot-rliq + funz = theta_iceliq(exner,tempz,rliq,0.) - thil + zside = funa*funz < 0.0 if (zside) exit zgssloop end do zgssloop - if (.not. zside) then - write (unit=*,fmt='(a)') ' ====== No second guess for you... ======' - write (unit=*,fmt='(a)') ' + INPUT variables: ' - write (unit=*,fmt='(a,1x,es14.7)') 'THIL =',thil - write (unit=*,fmt='(a,1x,es14.7)') 'TEMP =',temp - write (unit=*,fmt='(a,1x,es14.7)') 'PRES =',pres - write (unit=*,fmt='(a,1x,es14.7)') 'RTOT =',rtot - write (unit=*,fmt='(a,1x,es14.7)') 'RVAP =',rvap - write (unit=*,fmt='(a,1x,i5)') 'CALL =',iflg - write (unit=*,fmt='(a)') ' ============ Failed guess... ===========' - write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLA =',tlcla,'FUNA =',funa - write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLZ =',tlclz,'FUNC =',funz - write (unit=*,fmt='(2(a,1x,es14.7))') 'DELTA =',delta,'FUNN =',funnow + if (.not. zside) & call fatal_error('Failed finding the second guess for regula falsi' & - ,'lcl_il','therm_lib.f90') - end if + ,'thil2tqliq','rthrm.f90') end if - !---- Continue iterative method --------------------------------------------------! - fpoloop: do itb=itn+1,maxfpo - - tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) - - pvap = eslif(tlcl,brrr_cold) - - funnow = tlcl * (es00/pvap)**rocp - thil + !---------------------------------------------------------------------------------! - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=21,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),3(a,1x,es11.4,1x))') & - ! 'ANSWER: itb=',itn,'tlcl=',tlcl-t00,'eslcl=',0.01*pvap & - ! ,'dzlcl=',dzlcl,'plcl=',plcl*0.01,'funa=',funa,'funz=',funz - !write (unit=21,fmt='(a)') '-------------------------------------------------------' - !write (unit=21,fmt='(a)') ' ' - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - else - write (unit=*,fmt='(a)') '-------------------------------------------------------' - write (unit=*,fmt='(a)') ' LCL Temperature didn''t converge!!!' - write (unit=*,fmt='(a,1x,i5,1x,a)') ' I gave up, after',maxfpo,'iterations...' - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' Input values.' - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a,1x,f12.4)' ) 'theta_il [ K] =',thil - write (unit=*,fmt='(a,1x,f12.4)' ) 'Pressure [ hPa] =',0.01*pres - write (unit=*,fmt='(a,1x,f12.4)' ) 'Temperature [ °C] =',temp-t00 - write (unit=*,fmt='(a,1x,f12.4)' ) 'rtot [ g/kg] =',1000.*rtot - write (unit=*,fmt='(a,1x,f12.4)' ) 'rvap [ g/kg] =',1000.*rvap - write (unit=*,fmt='(a,1x,i5)' ) 'call [ ---] =',iflg - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' Last iteration outcome.' - write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcla [ °C] =',tlcla-t00 - write (unit=*,fmt='(a,1x,f12.4)' ) 'tlclz [ °C] =',tlclz-t00 - write (unit=*,fmt='(a,1x,f12.4)' ) 'fun [ K] =',funnow - write (unit=*,fmt='(a,1x,f12.4)' ) 'funa [ K] =',funa - write (unit=*,fmt='(a,1x,f12.4)' ) 'funz [ K] =',funz - write (unit=*,fmt='(a,1x,f12.4)' ) 'deriv [ ----] =',deriv - write (unit=*,fmt='(a,1x,es12.4)') 'toler [ ----] =',toler - write (unit=*,fmt='(a,1x,es12.4)') 'error [ ----] =' & - ,abs(tlclz-tlcla)/tlclz - write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcl [ °C] =',tlcl - call fatal_error('TLCL didn''t converge, gave up!','lcl_il','therm_lib.f90') - end if + + if (.not. converged) call fatal_error('Failed finding equilibrium, I gave up!' & + ,'thil2tqliq','therm_lib.f90') return - end subroutine lcl_il + end subroutine thil2tqliq !=======================================================================================! !=======================================================================================! @@ -3032,35 +4987,48 @@ end subroutine lcl_il !=======================================================================================! !=======================================================================================! ! This subroutine computes the temperature and fraction of liquid water from the ! - ! internal energy . ! + ! intensive internal energy [J/kg]. ! !---------------------------------------------------------------------------------------! - subroutine qtk(q,tempk,fracliq) - use consts_coms, only: cliqi,cicei,allii,t3ple,qicet3,qliqt3,tsupercool + subroutine uint2tl(uint,temp,fliq) + use consts_coms, only : cliqi & ! intent(in) + , cicei & ! intent(in) + , allii & ! intent(in) + , t3ple & ! intent(in) + , uiicet3 & ! intent(in) + , uiliqt3 & ! intent(in) + , tsupercool_liq ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: q ! Internal energy [ J/kg] - real, intent(out) :: tempk ! Temperature [ K] - real, intent(out) :: fracliq ! Liquid Fraction (0-1) [ ---] + real(kind=4), intent(in) :: uint ! Internal energy [ J/kg] + real(kind=4), intent(out) :: temp ! Temperature [ K] + real(kind=4), intent(out) :: fliq ! Liquid Fraction (0-1) [ ---] !------------------------------------------------------------------------------------! - !----- Internal energy below qwfroz, all ice ---------------------------------------! - if (q <= qicet3) then - fracliq = 0. - tempk = q * cicei - !----- Internal energy, above qwmelt, all liquid ------------------------------------! - elseif (q >= qliqt3) then - fracliq = 1. - tempk = q * cliqi + tsupercool - !----- Changing phase, it must be at freezing point ---------------------------------! + !------------------------------------------------------------------------------------! + ! Compare the internal energy with the reference values to decide which phase ! + ! the water is. ! + !------------------------------------------------------------------------------------! + if (uint <= uiicet3) then + !----- Internal energy below qwfroz, all ice ------------------------------------! + fliq = 0. + temp = uint * cicei + !---------------------------------------------------------------------------------! + elseif (uint >= uiliqt3) then + !----- Internal energy, above qwmelt, all liquid ---------------------------------! + fliq = 1. + temp = uint * cliqi + tsupercool_liq + !---------------------------------------------------------------------------------! else - fracliq = (q-qicet3) * allii - tempk = t3ple - endif + !----- Changing phase, it must be at freezing point ------------------------------! + fliq = (uint - uiicet3) * allii + temp = t3ple + !---------------------------------------------------------------------------------! + end if !------------------------------------------------------------------------------------! return - end subroutine qtk + end subroutine uint2tl !=======================================================================================! !=======================================================================================! @@ -3071,64 +5039,78 @@ end subroutine qtk !=======================================================================================! !=======================================================================================! - ! This subroutine computes the temperature (Kelvin) and liquid fraction from inter- ! - ! nal energy (J/m² or J/m³), mass (kg/m² or kg/m³), and heat capacity (J/m²/K or ! - ! J/m³/K). ! + ! This subroutine computes the temperature (Kelvin) and liquid fraction from ! + ! extensive internal energy (J/m² or J/m³), water mass (kg/m² or kg/m³), and heat ! + ! capacity (J/m²/K or J/m³/K). ! !---------------------------------------------------------------------------------------! - subroutine qwtk(qw,w,dryhcap,tempk,fracliq) - use consts_coms, only: cliqi,cliq,cicei,cice,allii,alli,t3ple,tsupercool + subroutine uextcm2tl(uext,wmass,dryhcap,temp,fliq) + use consts_coms, only : cliqi & ! intent(in) + , cliq & ! intent(in) + , cicei & ! intent(in) + , cice & ! intent(in) + , allii & ! intent(in) + , alli & ! intent(in) + , t3ple & ! intent(in) + , tsupercool_liq ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: qw ! Internal energy [ J/m²] or [ J/m³] - real, intent(in) :: w ! Density [ kg/m²] or [ kg/m³] - real, intent(in) :: dryhcap ! Heat capacity of nonwater part [J/m²/K] or [J/m³/K] - real, intent(out) :: tempk ! Temperature [ K] - real, intent(out) :: fracliq ! Liquid fraction (0-1) [ ---] + real(kind=4), intent(in) :: uext ! Extensive internal energy [ J/m²] or [ J/m³] + real(kind=4), intent(in) :: wmass ! Water mass [ kg/m²] or [ kg/m³] + real(kind=4), intent(in) :: dryhcap ! Heat cap. of "dry" part [J/m²/K] or [J/m³/K] + real(kind=4), intent(out) :: temp ! Temperature [ K] + real(kind=4), intent(out) :: fliq ! Liquid fraction (0-1) [ ---] !----- Local variable ---------------------------------------------------------------! - real :: qwfroz ! qw of ice at triple point [ J/m²] or [ J/m³] - real :: qwmelt ! qw of liquid at triple point [ J/m²] or [ J/m³] + real(kind=4) :: uefroz ! qw of ice at triple pt. [ J/m²] or [ J/m³] + real(kind=4) :: uemelt ! qw of liq. at triple pt. [ J/m²] or [ J/m³] !------------------------------------------------------------------------------------! - !----- Converting melting heat to J/m² or J/m³ --------------------------------------! - qwfroz = (dryhcap + w*cice) * t3ple - qwmelt = qwfroz + w*alli - !------------------------------------------------------------------------------------! - - !------------------------------------------------------------------------------------! - ! This is analogous to the qtk computation, we should analyse the magnitude of ! - ! the internal energy to choose between liquid, ice, or both by comparing with our. ! - ! know boundaries. ! - !------------------------------------------------------------------------------------! - !----- Internal energy below qwfroz, all ice ---------------------------------------! - if (qw < qwfroz) then - fracliq = 0. - tempk = qw / (cice * w + dryhcap) - !----- Internal energy, above qwmelt, all liquid ------------------------------------! - elseif (qw > qwmelt) then - fracliq = 1. - tempk = (qw + w * cliq * tsupercool) / (dryhcap + w*cliq) - !------------------------------------------------------------------------------------! - ! We are at the freezing point. If water mass is so tiny that the internal ! - ! energy of frozen and melted states are the same given the machine precision, then ! - ! we assume that water content is negligible and we impose 50% frozen for ! - ! simplicity. ! + + !----- Convert melting heat to J/m² or J/m³ -----------------------------------------! + uefroz = (dryhcap + wmass * cice) * t3ple + uemelt = uefroz + wmass * alli !------------------------------------------------------------------------------------! - elseif (qwfroz == qwmelt) then - fracliq = 0.5 - tempk = t3ple + + + !------------------------------------------------------------------------------------! - ! Changing phase, it must be at freezing point. The max and min are here just to ! - ! avoid tiny deviations beyond 0. and 1. due to floating point arithmetics. ! + ! This is analogous to the uint2tl computation, we should analyse the magnitude ! + ! of the internal energy to choose between liquid, ice, or both by comparing with ! + ! the known boundaries. ! !------------------------------------------------------------------------------------! + if (uext < uefroz) then + !----- Internal energy below qwfroz, all ice ------------------------------------! + fliq = 0. + temp = uext / (cice * wmass + dryhcap) + !---------------------------------------------------------------------------------! + elseif (uext > uemelt) then + !----- Internal energy, above qwmelt, all liquid ---------------------------------! + fliq = 1. + temp = (uext + wmass * cliq * tsupercool_liq) / (dryhcap + wmass * cliq) + !---------------------------------------------------------------------------------! + elseif (uefroz == uemelt) then + !---------------------------------------------------------------------------------! + ! We are at the freezing point. If water mass is so tiny that the internal ! + ! energy of frozen and melted states are the same given the machine precision, ! + ! then we assume that water content is negligible and we impose 50% frozen for ! + ! simplicity. ! + !---------------------------------------------------------------------------------! + fliq = 0.5 + temp = t3ple + !---------------------------------------------------------------------------------! else - fracliq = min(1.,max(0.,(qw - qwfroz) * allii / w)) - tempk = t3ple + !---------------------------------------------------------------------------------! + ! Changing phase, it must be at freezing point. The max and min are here just ! + ! to avoid tiny deviations beyond 0. and 1. due to floating point arithmetics. ! + !---------------------------------------------------------------------------------! + fliq = min(1.,max(0.,(uext - uefroz) * allii / wmass)) + temp = t3ple + !---------------------------------------------------------------------------------! end if !------------------------------------------------------------------------------------! return - end subroutine qwtk + end subroutine uextcm2tl !=======================================================================================! !=======================================================================================! end module therm_lib diff --git a/ED/src/utils/therm_lib8.f90 b/ED/src/utils/therm_lib8.f90 index 4e1e304c5..f3f6c7e13 100644 --- a/ED/src/utils/therm_lib8.f90 +++ b/ED/src/utils/therm_lib8.f90 @@ -26,25 +26,31 @@ module therm_lib8 ! accurate the result, but it will slow down the run. Notice that we are using the ! ! tolerance that is based on the single precision... ! !---------------------------------------------------------------------------------------! - real(kind=8), parameter :: toler8 = dble(toler4) - - - integer, parameter :: maxfpo = maxfpo4 ! Maximum # of iterations before crash- - ! ing for false position method. - - integer, parameter :: maxit = maxit4 ! Maximum # of iterations before crash- - ! ing, for other methods. + real(kind=8), parameter :: toler8 = dble(toler4) ! Relative tolerance for iterative + ! methods. The smaller the + ! value, the more accurate the + ! result, but smaller values will + ! slow down the run. + integer , parameter :: maxfpo = maxfpo4 ! Maximum # of iterations before + ! crashing for false position + ! method. + integer , parameter :: maxit = maxit4 ! Maximum # of iterations before + ! crashing, for other methods. + integer , parameter :: maxlev = maxlev4 ! Maximum # of levels for adaptive + ! quadrature methods. + logical , parameter :: newthermo = newthermo4 ! Use new thermodynamics [T|F] + !---------------------------------------------------------------------------------------! - integer, parameter :: maxlev = maxlev4 ! Maximum # of levels for adaptive - ! quadrature methods. - logical, parameter :: newthermo = newthermo4 ! Use new thermodynamics [T|F] !---------------------------------------------------------------------------------------! ! This is the "level" variable, that used to be in micphys. Since it affects more the ! ! thermodynamics choices than the microphysics, it was moved to here. ! !---------------------------------------------------------------------------------------! integer, parameter :: level = level4 + !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! ! The following three variables are just the logical tests on variable "level", ! @@ -79,6 +85,7 @@ module therm_lib8 real(kind=8), dimension(2) , parameter :: ttt_108 = (/4.15d-2 , 2.188d2 /) !---------------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------------! ! These constants came from the paper in which the saturation vapour pressure is ! ! based on: ! @@ -91,60 +98,81 @@ module therm_lib8 ! what was on the original code... ! !---------------------------------------------------------------------------------------! !----- Coefficients for esat (liquid) --------------------------------------------------! - real(kind=8), dimension(0:8), parameter :: cll8 = & - (/ .6105851d+03, .4440316d+02, .1430341d+01 & - , .2641412d-01, .2995057d-03, .2031998d-05 & - , .6936113d-08, .2564861d-11, -.3704404d-13 /) + real(kind=8), dimension(0:8), parameter :: cll8 = (/ .6105851d+03, .4440316d+02 & + , .1430341d+01, .2641412d-01 & + , .2995057d-03, .2031998d-05 & + , .6936113d-08, .2564861d-11 & + , -.3704404d-13 /) !----- Coefficients for esat (ice) -----------------------------------------------------! - real(kind=8), dimension(0:8), parameter :: cii8 = & - (/ .6114327d+03, .5027041d+02, .1875982d+01 & - , .4158303d-01, .5992408d-03, .5743775d-05 & - , .3566847d-07, .1306802d-09, .2152144d-12 /) + real(kind=8), dimension(0:8), parameter :: cii8 = (/ .6114327d+03, .5027041d+02 & + , .1875982d+01, .4158303d-01 & + , .5992408d-03, .5743775d-05 & + , .3566847d-07, .1306802d-09 & + , .2152144d-12 /) !----- Coefficients for d(esat)/dT (liquid) --------------------------------------------! - real(kind=8), dimension(0:8), parameter :: dll8 = & - (/ .4443216d+02, .2861503d+01, .7943347d-01 & - , .1209650d-02, .1036937d-04, .4058663d-07 & - ,-.5805342d-10, -.1159088d-11, -.3189651d-14 /) + real(kind=8), dimension(0:8), parameter :: dll8 = (/ .4443216d+02, .2861503d+01 & + , .7943347d-01, .1209650d-02 & + , .1036937d-04, .4058663d-07 & + , -.5805342d-10, -.1159088d-11 & + , -.3189651d-14 /) !----- Coefficients for esat (ice) -----------------------------------------------------! - real(kind=8), dimension(0:8), parameter :: dii8 = & - (/ .5036342d+02, .3775758d+01, .1269736d+00 & - , .2503052d-02, .3163761d-04, .2623881d-06 & - , .1392546d-08, .4315126d-11, .5961476d-14 /) + real(kind=8), dimension(0:8), parameter :: dii8 = (/ .5036342d+02, .3775758d+01 & + , .1269736d+00, .2503052d-02 & + , .3163761d-04, .2623881d-06 & + , .1392546d-08, .4315126d-11 & + , .5961476d-14 /) !---------------------------------------------------------------------------------------! - !=======================================================================================! !=======================================================================================! contains + + !=======================================================================================! !=======================================================================================! ! This function calculates the liquid saturation vapour pressure as a function of ! ! Kelvin temperature. This expression came from MK05, equation (10). ! !---------------------------------------------------------------------------------------! real(kind=8) function eslf8(temp,l1funout,l2funout,ttfunout) - use consts_coms, only : t008 + use consts_coms, only : t008 ! ! intent(in) implicit none - real(kind=8), intent(in) :: temp - real(kind=8), intent(out), optional :: l1funout,ttfunout,l2funout - real(kind=8) :: l1fun,ttfun,l2fun,x + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! + real(kind=8), intent(out), optional :: l1funout ! Function for high temperatures + real(kind=8), intent(out), optional :: ttfunout ! Interpolation function + real(kind=8), intent(out), optional :: l2funout ! Function for low temperatures + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: l1fun ! + real(kind=8) :: ttfun ! + real(kind=8) :: l2fun ! + real(kind=8) :: x ! + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Choose between the old and the new thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then !----- Updated method, using MK05 ------------------------------------------------! - l1fun = l01_108(0) + l01_108(1)/temp + l01_108(2)*log(temp) + l01_108(3) * temp - l2fun = l02_108(0) + l02_108(1)/temp + l02_108(2)*log(temp) + l02_108(3) * temp - ttfun = tanh(ttt_108(1) * (temp - ttt_108(2))) - eslf8 = exp(l1fun + ttfun*l2fun) + l1fun = l01_108(0) + l01_108(1)/temp + l01_108(2)*log(temp) + l01_108(3) * temp + l2fun = l02_108(0) + l02_108(1)/temp + l02_108(2)*log(temp) + l02_108(3) * temp + ttfun = tanh(ttt_108(1) * (temp - ttt_108(2))) + eslf8 = exp(l1fun + ttfun*l2fun) + !---------------------------------------------------------------------------------! if (present(l1funout)) l1funout = l1fun if (present(l2funout)) l2funout = l2fun if (present(ttfunout)) ttfunout = ttfun else !----- Original method, using polynomial fit (FWC92) -----------------------------! - x = max(-8.d1,temp-t008) + x = max(-8.0d1,temp-t008) eslf8 = cll8(0) + x * (cll8(1) + x * (cll8(2) + x * (cll8(3) + x * (cll8(4) & + x * (cll8(5) + x * (cll8(6) + x * (cll8(7) + x * cll8(8)) )))))) + !---------------------------------------------------------------------------------! if (present(l1funout)) l1funout = eslf8 if (present(l2funout)) l2funout = eslf8 @@ -167,26 +195,41 @@ end function eslf8 ! Kelvin temperature, based on MK05 equation (7). ! !---------------------------------------------------------------------------------------! real(kind=8) function esif8(temp,iifunout) - use consts_coms, only : t008 + use consts_coms, only : t008 ! ! intent(in) implicit none - real(kind=8), intent(in) :: temp + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! real(kind=8), intent(out), optional :: iifunout - real(kind=8) :: iifun,x + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: iifun + real(kind=8) :: x + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Choose between the old and the new thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then + !----- Updated method, using MK05 ------------------------------------------------! - iifun = iii_78(0) + iii_78(1)/temp + iii_78(2) * log(temp) + iii_78(3) * temp - esif8 = exp(iifun) - + iifun = iii_78(0) + iii_78(1)/temp + iii_78(2) * log(temp) + iii_78(3) * temp + esif8 = exp(iifun) + !---------------------------------------------------------------------------------! + + if (present(iifunout)) iifunout=iifun else !----- Original method, using polynomial fit (FWC92) -----------------------------! - x=max(-8.d1,temp-t008) + x = max(-8.d1,temp-t008) esif8 = cii8(0) + x * (cii8(1) + x * (cii8(2) + x * (cii8(3) + x * (cii8(4) & - + x * (cii8(5) + x * (cii8(6) + x * (cii8(7) + x * cii8(8)) )))))) + + x * (cii8(5) + x * (cii8(6) + x * (cii8(7) + x * cii8(8)))))))) + !---------------------------------------------------------------------------------! if (present(iifunout)) iifunout=esif8 end if + !------------------------------------------------------------------------------------! + return end function esif8 !=======================================================================================! @@ -204,23 +247,43 @@ end function esif8 ! below or above the triple point. ! !---------------------------------------------------------------------------------------! real(kind=8) function eslif8(temp,useice) - use consts_coms, only: t3ple8 + use consts_coms, only : t3ple8 ! ! intent(in) implicit none + !----- Required arguments. ----------------------------------------------------------! real(kind=8), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! logical , intent(in), optional :: useice - logical :: brrr_cold + !----- Local variables. -------------------------------------------------------------! + logical :: frozen + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple8 + frozen = useice .and. temp < t3ple8 else - brrr_cold = bulk_on .and. temp < t3ple8 + frozen = bulk_on .and. temp < t3ple8 end if + !------------------------------------------------------------------------------------! - if (brrr_cold) then - eslif8 = esif8(temp) ! Ice saturation vapour pressure + + + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- Saturation vapour pressure for ice. ---------------------------------------! + eslif8 = esif8(temp) + !---------------------------------------------------------------------------------! else - eslif8 = eslf8(temp) ! Liquid saturation vapour pressure + !----- Saturation vapour pressure for liquid. ------------------------------------! + eslif8 = eslf8(temp) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return end function eslif8 @@ -238,13 +301,28 @@ end function eslif8 ! of pressure and Kelvin temperature. ! !---------------------------------------------------------------------------------------! real(kind=8) function rslf8(pres,temp) - use consts_coms, only : ep8,toodry8 + use consts_coms, only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pres,temp - real(kind=8) :: esl + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: esl ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + - esl = eslf8(temp) + !----- First we find the saturation vapour pressure. --------------------------------! + esl = eslf8(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the mixing ! + ! ratio. ! + !------------------------------------------------------------------------------------! rslf8 = max(toodry8,ep8*esl/(pres-esl)) + !------------------------------------------------------------------------------------! return end function rslf8 @@ -262,13 +340,28 @@ end function rslf8 ! pressure and Kelvin temperature. ! !---------------------------------------------------------------------------------------! real(kind=8) function rsif8(pres,temp) - use consts_coms, only : ep8,toodry8 + use consts_coms, only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pres,temp - real(kind=8) :: esi + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: esi ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- First we find the saturation vapour pressure. --------------------------------! + esi = esif8(temp) + !------------------------------------------------------------------------------------! + - esi = esif8(temp) + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the mixing ! + ! ratio. ! + !------------------------------------------------------------------------------------! rsif8 = max(toodry8,ep8*esi/(pres-esi)) + !------------------------------------------------------------------------------------! return end function rsif8 @@ -286,28 +379,54 @@ end function rsif8 ! depending on temperature, as a function of pressure and Kelvin temperature. ! !---------------------------------------------------------------------------------------! real(kind=8) function rslif8(pres,temp,useice) - use consts_coms, only: t3ple8,ep8 + use consts_coms, only : t3ple8 & ! intent(in) + , ep8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pres,temp + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: pres + real(kind=8), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! logical , intent(in), optional :: useice + !----- Local variables. -------------------------------------------------------------! real(kind=8) :: esz - logical :: brrr_cold + logical :: frozen + !------------------------------------------------------------------------------------! - !----- Checking which saturation (liquid or ice) I should use here ------------------! + + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple8 + frozen = useice .and. temp < t3ple8 else - brrr_cold = bulk_on .and. temp < t3ple8 + frozen = bulk_on .and. temp < t3ple8 end if - - !----- Finding the saturation vapour pressure ---------------------------------------! - if (brrr_cold) then + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- Saturation vapour pressure for ice. ---------------------------------------! esz = esif8(temp) + !---------------------------------------------------------------------------------! else + !----- Saturation vapour pressure for liquid. ------------------------------------! esz = eslf8(temp) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the mixing ! + ! ratio. ! + !------------------------------------------------------------------------------------! rslif8 = ep8 * esz / (pres - esz) + !------------------------------------------------------------------------------------! return end function rslif8 @@ -319,6 +438,149 @@ end function rslif8 + !=======================================================================================! + !=======================================================================================! + ! This function calculates the liquid saturation specific humidity as a function of ! + ! pressure and Kelvin temperature. ! + !---------------------------------------------------------------------------------------! + real(kind=8) function qslf8(pres,temp) + use consts_coms, only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: esl ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- First we find the saturation vapour pressure. --------------------------------! + esl = eslf8(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the ! + ! specific humidity. ! + !------------------------------------------------------------------------------------! + qslf8 = max(toodry8,ep8 * esl/( pres - (1.d0 - ep8) * esl) ) + !------------------------------------------------------------------------------------! + + return + end function qslf8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function calculates the ice saturation specific humidity as a function of ! + ! pressure and Kelvin temperature. ! + !---------------------------------------------------------------------------------------! + real(kind=8) function qsif8(pres,temp) + use consts_coms, only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: esi ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- First we find the saturation vapour pressure. --------------------------------! + esi = esif8(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the ! + ! specific humidity. ! + !------------------------------------------------------------------------------------! + qsif8 = max(toodry8,ep8 * esi/( pres - (1.d0 - ep8) * esi) ) + !------------------------------------------------------------------------------------! + + return + end function qsif8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function calculates the saturation specific humidity, over liquid or ice ! + ! depending on temperature, as a function of pressure and Kelvin temperature. ! + !---------------------------------------------------------------------------------------! + real(kind=8) function qslif8(pres,temp,useice) + use consts_coms, only : t3ple8 & ! intent(in) + , ep8 & ! intent(in) + , toodry8 ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: pres + real(kind=8), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: esz + logical :: frozen + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! + if (present(useice)) then + frozen = useice .and. temp < t3ple8 + else + frozen = bulk_on .and. temp < t3ple8 + end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- Saturation vapour pressure for ice. ---------------------------------------! + esz = esif8(temp) + !---------------------------------------------------------------------------------! + else + !----- Saturation vapour pressure for liquid. ------------------------------------! + esz = eslf8(temp) + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the ! + ! specific humidity. ! + !------------------------------------------------------------------------------------! + qslif8 = max(toodry8, ep8 * esz/( pres - (1.d0 - ep8) * esz) ) + !------------------------------------------------------------------------------------! + + return + end function qslif8 + !=======================================================================================! + !=======================================================================================! + + + + + !=======================================================================================! !=======================================================================================! @@ -326,12 +588,28 @@ end function rslif8 ! function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! real(kind=8) function rhovsl8(temp) - use consts_coms, only : rh2o8 + use consts_coms, only : rh2o8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: temp - real(kind=8) :: eequ - eequ = eslf8(temp) + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: eequ ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the equilibrium (saturation) vapour pressure. ! + !------------------------------------------------------------------------------------! + eequ = eslf8(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the saturation density. ! + !------------------------------------------------------------------------------------! rhovsl8 = eequ / (rh2o8 * temp) + !------------------------------------------------------------------------------------! + return end function rhovsl8 !=======================================================================================! @@ -349,12 +627,28 @@ end function rhovsl8 ! function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! real(kind=8) function rhovsi8(temp) - use consts_coms, only : rh2o8 + use consts_coms, only : rh2o8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: temp - real(kind=8) :: eequ - eequ = esif8(temp) + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: eequ ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the equilibrium (saturation) vapour pressure. ! + !------------------------------------------------------------------------------------! + eequ = esif8(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the saturation density. ! + !------------------------------------------------------------------------------------! rhovsi8 = eequ / (rh2o8 * temp) + !------------------------------------------------------------------------------------! + return end function rhovsi8 !=======================================================================================! @@ -373,19 +667,35 @@ end function rhovsi8 ! temperature. ! !---------------------------------------------------------------------------------------! real(kind=8) function rhovsil8(temp,useice) - use consts_coms, only : rh2o8 + use consts_coms, only : rh2o8 ! ! intent(in) implicit none + !----- Required arguments. ----------------------------------------------------------! real(kind=8), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! logical , intent(in), optional :: useice + !----- Local variables. -------------------------------------------------------------! real(kind=8) :: eequ + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Pass the "useice" argument to eslif, so it may decide whether ice thermo- ! + ! dynamics is to be used. ! + !------------------------------------------------------------------------------------! if (present(useice)) then eequ = eslif8(temp,useice) else eequ = eslif8(temp) end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the saturation density. ! + !------------------------------------------------------------------------------------! rhovsil8 = eequ / (rh2o8 * temp) + !------------------------------------------------------------------------------------! return end function rhovsil8 @@ -403,24 +713,39 @@ end function rhovsil8 ! pressure with respect to temperature as a function of Kelvin temperature. ! !---------------------------------------------------------------------------------------! real(kind=8) function eslfp8(temp) - use consts_coms, only: t008 + use consts_coms, only : t008 ! ! intent(in) implicit none + !------ Arguments. ------------------------------------------------------------------! real(kind=8), intent(in) :: temp - real(kind=8) :: esl,l2fun,ttfun,l1prime,l2prime,ttprime,x + !------ Local variables. ------------------------------------------------------------! + real(kind=8) :: esl + real(kind=8) :: l2fun + real(kind=8) :: ttfun + real(kind=8) :: l1prime + real(kind=8) :: l2prime + real(kind=8) :: ttprime + real(kind=8) :: x + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide which function to use, based on the thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then !----- Updated method, using MK05 ------------------------------------------------! esl = eslf8(temp,l2funout=l2fun,ttfunout=ttfun) l1prime = -l01_108(1)/(temp*temp) + l01_108(2)/temp + l01_108(3) l2prime = -l02_108(1)/(temp*temp) + l02_108(2)/temp + l02_108(3) - ttprime = ttt_108(1)*(1.-ttfun*ttfun) + ttprime = ttt_108(1)*(1.d0 - ttfun*ttfun) eslfp8 = esl * (l1prime + l2prime*ttfun + l2fun*ttprime) else !----- Original method, using polynomial fit (FWC92) -----------------------------! - x=max(-8.d1,temp-t008) + x = max(-8.d1,temp-t008) eslfp8 = dll8(0) + x * (dll8(1) + x * (dll8(2) + x * (dll8(3) + x * (dll8(4) & - + x * (dll8(5) + x * (dll8(6) + x * (dll8(7) + x * dll8(8)) )))))) + + x * (dll8(5) + x * (dll8(6) + x * (dll8(7) + x * dll8(8)))))))) end if + !------------------------------------------------------------------------------------! return @@ -439,22 +764,33 @@ end function eslfp8 ! with respect to temperature as a function of Kelvin temperature. ! !---------------------------------------------------------------------------------------! real(kind=8) function esifp8(temp) - use consts_coms, only: t008 + use consts_coms, only : t008 ! ! intent(in) implicit none + !------ Arguments. ------------------------------------------------------------------! real(kind=8), intent(in) :: temp - real(kind=8) :: esi,iiprime,x + !------ Local variables. ------------------------------------------------------------! + real(kind=8) :: esi + real(kind=8) :: iiprime + real(kind=8) :: x + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide which function to use, based on the thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then !----- Updated method, using MK05 ------------------------------------------------! - esi = esif8(temp) - iiprime = -iii_78(1)/(temp*temp) + iii_78(2)/temp + iii_78(3) - esifp8 = esi * iiprime + esi = esif8(temp) + iiprime = -iii_78(1)/(temp*temp) + iii_78(2)/temp + iii_78(3) + esifp8 = esi * iiprime else !----- Original method, using polynomial fit (FWC92) -----------------------------! - x=max(-8.d1,temp-t008) + x = max(-8.d1,temp-t008) esifp8 = dii8(0) + x * (dii8(1) + x * (dii8(2) + x * (dii8(3) + x * (dii8(4) & - + x * (dii8(5) + x * (dii8(6) + x * (dii8(7) + x * dii8(8)) )))))) + + x * (dii8(5) + x * (dii8(6) + x * (dii8(7) + x * dii8(8)))))))) end if + !------------------------------------------------------------------------------------! return end function esifp8 @@ -473,23 +809,43 @@ end function esifp8 ! whether the temperature is below or above the triple point. ! !---------------------------------------------------------------------------------------! real(kind=8) function eslifp8(temp,useice) - use consts_coms, only: t3ple8 + use consts_coms, only : t3ple8 ! ! intent(in) implicit none + !------ Arguments. ------------------------------------------------------------------! real(kind=8), intent(in) :: temp + !------ Local variables. ------------------------------------------------------------! logical , intent(in), optional :: useice - logical :: brrr_cold + logical :: frozen + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple8 + frozen = useice .and. temp < t3ple8 else - brrr_cold = bulk_on .and. temp < t3ple8 + frozen = bulk_on .and. temp < t3ple8 end if + !------------------------------------------------------------------------------------! + - if (brrr_cold) then - eslifp8 = esifp8(temp) ! d(Ice saturation vapour pressure)/dT + + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- d(Saturation vapour pressure)/dT for ice. ---------------------------------! + eslifp8 = esifp8(temp) + !---------------------------------------------------------------------------------! else - eslifp8 = eslfp8(temp) ! d(Liquid saturation vapour pressure)/dT + !----- d(Saturation vapour pressure)/dT for liquid water. ------------------------! + eslifp8 = eslfp8(temp) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return end function eslifp8 @@ -509,17 +865,37 @@ end function eslifp8 ! ture. ! !---------------------------------------------------------------------------------------! real(kind=8) function rslfp8(pres,temp) - use consts_coms, only: ep8 + use consts_coms, only : ep8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pres,temp - real(kind=8) :: desdt,esl,pdry - - esl = eslf8(temp) - desdt = eslfp8(temp) - - pdry = pres-esl - rslfp8 = ep8 * pres * desdt / (pdry*pdry) - + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: esl ! Partial pressure [ Pa] + real(kind=8) :: desdt ! Derivative of partial pressure of water [ Pa/K] + real(kind=8) :: pdry ! Partial pressure of dry air [ Pa] + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! + esl = eslf8(temp) + desdt = eslfp8(temp) + !------------------------------------------------------------------------------------! + + + !----- Find the partial pressure of dry air. ----------------------------------------! + pdry = pres-esl + !------------------------------------------------------------------------------------! + + + !----- Find the partial derivative of mixing ratio. ---------------------------------! + rslfp8 = ep8 * pres * desdt / (pdry*pdry) + !------------------------------------------------------------------------------------! + return end function rslfp8 !=======================================================================================! @@ -538,17 +914,35 @@ end function rslfp8 ! ture. ! !---------------------------------------------------------------------------------------! real(kind=8) function rsifp8(pres,temp) - use consts_coms, only: ep8 + use consts_coms, only : ep8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pres,temp - real(kind=8) :: desdt,esi,pdry + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: esi ! Partial pressure [ Pa] + real(kind=8) :: desdt ! Derivative of partial pressure of water [ Pa/K] + real(kind=8) :: pdry ! Partial pressure of dry air [ Pa] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! + esi = esif8(temp) + desdt = esifp8(temp) + !------------------------------------------------------------------------------------! + + + !----- Find the partial pressure of dry air. ----------------------------------------! + pdry = pres-esi + !------------------------------------------------------------------------------------! - esi = esif8(temp) - desdt = esifp8(temp) - - pdry = pres-esi - rsifp8 = ep8 * pres * desdt / (pdry*pdry) + !----- Find the partial derivative of mixing ratio. ---------------------------------! + rsifp8 = ep8 * pres * desdt / (pdry*pdry) + !------------------------------------------------------------------------------------! return end function rsifp8 !=======================================================================================! @@ -567,23 +961,41 @@ end function rsifp8 ! ture. ! !---------------------------------------------------------------------------------------! real(kind=8) function rslifp8(pres,temp,useice) - use consts_coms, only: t3ple8 + use consts_coms, only: t3ple8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pres,temp - logical , intent(in), optional :: useice - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics? [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: desdt ! Derivative of vapour pressure [ Pa/K] + logical :: frozen ! Use the ice thermodynamics [ T|F] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide whether to use liquid water of ice for saturation, based on the temper- ! + ! ature and the settings. ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple8 + frozen = useice .and. temp < t3ple8 else - brrr_cold = bulk_on .and. temp < t3ple8 + frozen = bulk_on .and. temp < t3ple8 end if + !------------------------------------------------------------------------------------! - if (brrr_cold) then - rslifp8=rsifp8(pres,temp) + + !------------------------------------------------------------------------------------! + ! Call the function depending on the previous check. ! + !------------------------------------------------------------------------------------! + if (frozen) then + rslifp8 = rsifp8(pres,temp) else - rslifp8=rslfp8(pres,temp) + rslifp8 = rslfp8(pres,temp) end if + !------------------------------------------------------------------------------------! return end function rslifp8 @@ -602,14 +1014,29 @@ end function rslifp8 ! a function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! real(kind=8) function rhovslp8(temp) - use consts_coms, only : rh2o8 + use consts_coms, only : rh2o8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: temp - real(kind=8) :: es,desdt + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: es ! Vapour pressure [ Pa] + real(kind=8) :: desdt ! Vapour pressure derivative [ Pa/K] + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! + es = eslf8(temp) + desdt = eslfp8(temp) + !------------------------------------------------------------------------------------! + - es = eslf8(temp) - desdt = eslfp8(temp) + !----- Find the partial derivative of saturation density . --------------------------! rhovslp8 = (desdt-es/temp) / (rh2o8 * temp) + !------------------------------------------------------------------------------------! return end function rhovslp8 @@ -628,14 +1055,29 @@ end function rhovslp8 ! function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! real(kind=8) function rhovsip8(temp) - use consts_coms, only : rh2o8 + use consts_coms, only : rh2o8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: temp - real(kind=8) :: es,desdt + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: es ! Vapour pressure [ Pa] + real(kind=8) :: desdt ! Vapour pressure derivative [ Pa/K] + !------------------------------------------------------------------------------------! - es = esif8(temp) - desdt = esifp8(temp) - rhovsip8 = (desdt-es/temp) / (rh2o8 * temp) + + + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! + es = esif8(temp) + desdt = esifp8(temp) + !------------------------------------------------------------------------------------! + + + !----- Find the partial derivative of saturation density . --------------------------! + rhovsip8 = (desdt - es/temp) / (rh2o8 * temp) + !------------------------------------------------------------------------------------! return end function rhovsip8 @@ -655,23 +1097,39 @@ end function rhovsip8 ! based on the temperature. ! !---------------------------------------------------------------------------------------! real(kind=8) function rhovsilp8(temp,useice) - use consts_coms, only: t3ple8 + use consts_coms, only : t3ple8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: temp - logical , intent(in), optional :: useice - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics? [ T|F] + !----- Local variables. -------------------------------------------------------------! + logical :: frozen ! Derivative of vapour pressure [ Pa/K] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide whether to use liquid water of ice for saturation, based on the temper- ! + ! ature and the settings. ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple8 + frozen = useice .and. temp < t3ple8 else - brrr_cold = bulk_on .and. temp < t3ple8 + frozen = bulk_on .and. temp < t3ple8 end if + !------------------------------------------------------------------------------------! - if (brrr_cold) then + + !------------------------------------------------------------------------------------! + ! Call the function depending on the previous check. ! + !------------------------------------------------------------------------------------! + if (frozen) then rhovsilp8 = rhovsip8(temp) else rhovsilp8 = rhovslp8(temp) end if + !------------------------------------------------------------------------------------! return end function rhovsilp8 @@ -694,65 +1152,93 @@ end function rhovsilp8 !---------------------------------------------------------------------------------------! real(kind=8) function tslf8(pvap) - implicit none - !----- Argument ---------------------------------------------------------------------! + implicit none + !----- Arguments. -------------------------------------------------------------------! real(kind=8), intent(in) :: pvap ! Saturation vapour pressure [ Pa] - !----- Local variables for iterative method -----------------------------------------! + !----- Local variables for iterative method. ----------------------------------------! real(kind=8) :: deriv ! Function derivative [ Pa] real(kind=8) :: fun ! Function for which we seek a root. [ Pa] real(kind=8) :: funa ! Smallest guess function [ Pa] real(kind=8) :: funz ! Largest guess function [ Pa] real(kind=8) :: tempa ! Smallest guess (or previous guess) [ Pa] - real(kind=8) :: tempz ! Largest guess (or new guess ) [ Pa] + real(kind=8) :: tempz ! Largest guess (new guess in Newton) [ Pa] real(kind=8) :: delta ! Aux. var --- 2nd guess for bisection [ ] - integer :: itn,itb ! Iteration counter [ ---] + integer :: itn ! Iteration counter [ ---] + integer :: itb ! Iteration counter [ ---] logical :: converged ! Convergence handle [ ---] - logical :: zside ! Flag to check for 1-sided approach. [ ---] + logical :: zside ! Flag to check for one-sided approach [ ---] !------------------------------------------------------------------------------------! - !----- First Guess, using Bolton (1980) equation 11, giving es in Pa and T in K -----! + !----- First Guess, use Bolton (1980) equation 11, giving es in Pa and T in K -------! tempa = (2.965d1 * log(pvap) - 5.01678d3)/(log(pvap)-2.40854d1) funa = eslf8(tempa) - pvap deriv = eslfp8(tempa) - !----- Copying just in case it fails at the first iteration -------------------------! + !------------------------------------------------------------------------------------! + + + !----- Copy just in case it fails at the first iteration ----------------------------! tempz = tempa fun = funa - + !------------------------------------------------------------------------------------! + + !----- Enter Newton's method loop: --------------------------------------------------! converged = .false. newloop: do itn = 1,maxfpo/6 if (abs(deriv) < toler8) exit newloop !----- Too dangerous, go with bisection ----! - !----- Copying the previous guess ------------------------------------------------! + + !----- Copy the previous guess. --------------------------------------------------! tempa = tempz funa = fun - !----- New guess, its function and derivative evaluation -------------------------! + !---------------------------------------------------------------------------------! + + + !----- New guess, its function, and derivative evaluation. -----------------------! tempz = tempa - fun/deriv fun = eslf8(tempz) - pvap deriv = eslfp8(tempz) - + !---------------------------------------------------------------------------------! + + + !----- Check convergence. --------------------------------------------------------! converged = abs(tempa-tempz) < toler8 * tempz if (converged) then tslf8 = 5.d-1 * (tempa+tempz) return - elseif (fun == 0.d0) then !Converged by luck! + elseif (fun == 0.0d0) then + !----- Converged by luck. -----------------------------------------------------! tslf8 = tempz return end if + !---------------------------------------------------------------------------------! end do newloop + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! If we have reached this point, then Newton's method has failed. Use bisection ! + ! instead. For bisection, we need two guesses whose function has opposite signs. ! !------------------------------------------------------------------------------------! if (funa * fun < 0.d0) then + !----- We already have two guesses with opposite signs. --------------------------! funz = fun zside = .true. + !---------------------------------------------------------------------------------! else - if (abs(fun-funa) < 1.d2 * toler8 * tempa) then - delta = 1.d2 * toler8 * tempa + !----- Need to find the guesses with opposite signs. -----------------------------! + if (abs(fun-funa) < 1.d2*toler8*tempa) then + delta = 1.d2*toler8*tempa else - delta = max(abs(funa * (tempz-tempa)/(fun-funa)),1.d2 * toler8 * tempa) + delta = max(abs(funa * (tempz-tempa)/(fun-funa)),1.d2*toler8*tempa) end if + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! Try guesses on both sides of the first guess, increasingly further away ! + ! until we spot a good guess. ! + !---------------------------------------------------------------------------------! tempz = tempa + delta zside = .false. zgssloop: do itb=1,maxfpo @@ -762,11 +1248,22 @@ real(kind=8) function tslf8(pvap) if (zside) exit zgssloop end do zgssloop if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempa=',tempa,'funa=',funa - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempz=',tempz,'func=',funz + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the second guess:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' call fatal_error('Failed finding the second guess for regula falsi' & - ,'tslf8','therm_lib8.f90') + ,'tslf8','therm_lib8.f90') end if end if @@ -775,38 +1272,54 @@ real(kind=8) function tslf8(pvap) tslf8 = (funz*tempa-funa*tempz)/(funz-funa) !---------------------------------------------------------------------------------! - ! Now that we updated the guess, check whether they are really close. If so, ! + ! Now that we updated the guess, check whether they are really close. If so, ! ! it converged, I can use this as my guess. ! !---------------------------------------------------------------------------------! converged = abs(tslf8-tempa) < toler8 * tslf8 if (converged) exit bisloop - !------ Finding the new function -------------------------------------------------! + !------ Find the new function evaluation. ----------------------------------------! fun = eslf8(tslf8) - pvap + !---------------------------------------------------------------------------------! - !------ Defining my new interval based on the intermediate value theorem. --------! + + !------ Define the new interval based on the intermediate value theorem. ---------! if (fun*funa < 0.d0 ) then tempz = tslf8 funz = fun - !----- If we are updating zside again, modify aside (Illinois method) ---------! - if (zside) funa=funa * 5.d-1 - !----- We just updated zside, setting zside to true. --------------------------! + !----- If we are updating zside again, modify aside (Illinois method). --------! + if (zside) funa = funa * 5.d-1 + !----- We have just updated zside, so we set zside to true. -------------------! zside = .true. else tempa = tslf8 funa = fun - !----- If we are updating aside again, modify aside (Illinois method) ---------! - if (.not. zside) funz=funz * 5.d-1 - !----- We just updated aside, setting aside to true. --------------------------! + !----- If we are updating aside again, modify zside (Illinois method). --------! + if (.not. zside) funz = funz * 5.d-1 + !----- We have just updated aside, so we set zside to false. ------------------! zside = .false. end if end do bisloop if (.not.converged) then - call fatal_error('Temperature didn''t converge, giving up!!!' & - ,'tslf8','therm_lib8.f90') + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the solution:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' + call fatal_error('Temperature didn''t converge, we give up!!!' & + ,'tslf8','therm_lib8.f90') end if - + return end function tslf8 !=======================================================================================! @@ -828,7 +1341,7 @@ end function tslf8 real(kind=8) function tsif8(pvap) implicit none - !----- Argument ---------------------------------------------------------------------! + !----- Arguments. -------------------------------------------------------------------! real(kind=8), intent(in) :: pvap ! Saturation vapour pressure [ Pa] !----- Local variables for iterative method -----------------------------------------! real(kind=8) :: deriv ! Function derivative [ Pa] @@ -836,56 +1349,81 @@ real(kind=8) function tsif8(pvap) real(kind=8) :: funa ! Smallest guess function [ Pa] real(kind=8) :: funz ! Largest guess function [ Pa] real(kind=8) :: tempa ! Smallest guess (or previous guess) [ Pa] - real(kind=8) :: tempz ! Largest guess (or new guess) [ Pa] + real(kind=8) :: tempz ! Largest guess (new guess in Newton) [ Pa] real(kind=8) :: delta ! Aux. var --- 2nd guess for bisection [ ] - integer :: itn,itb ! Iteration counter [ ---] + integer :: itn + integer :: itb ! Iteration counter [ ---] logical :: converged ! Convergence handle [ ---] logical :: zside ! Flag to check for one-sided approach [ ---] !------------------------------------------------------------------------------------! - !----- First Guess, using Murphy-Koop (2005), equation 8. ---------------------------! + !----- First Guess, use Murphy-Koop (2005), equation 8. -----------------------------! tempa = (1.814625d0 * log(pvap) +6.190134d3)/(2.9120d1 - log(pvap)) funa = esif8(tempa) - pvap deriv = esifp8(tempa) - !----- Copying just in case it fails at the first iteration -------------------------! + !------------------------------------------------------------------------------------! + + + !----- Copy just in case it fails at the first iteration ----------------------------! tempz = tempa fun = funa - + !------------------------------------------------------------------------------------! + + !----- Enter Newton's method loop: --------------------------------------------------! converged = .false. newloop: do itn = 1,maxfpo/6 if (abs(deriv) < toler8) exit newloop !----- Too dangerous, go with bisection ----! - !----- Copying the previous guess ------------------------------------------------! + + !----- Copy the previous guess. --------------------------------------------------! tempa = tempz funa = fun - !----- New guess, its function and derivative evaluation -------------------------! + + + !----- New guess, its function, and derivative evaluation. -----------------------! tempz = tempa - fun/deriv fun = esif8(tempz) - pvap deriv = esifp8(tempz) - + !---------------------------------------------------------------------------------! + + + !----- Check convergence. --------------------------------------------------------! converged = abs(tempa-tempz) < toler8 * tempz if (converged) then - tsif8 = 5.d-1*(tempa+tempz) + tsif8 = 5.d-1 * (tempa+tempz) return elseif (fun == 0.d0) then tsif8 = tempz return end if end do newloop + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! If we have reached this point, then Newton's method has failed. Use bisection ! + ! instead. For bisection, we need two guesses whose function has opposite signs. ! !------------------------------------------------------------------------------------! if (funa * fun < 0.d0) then + !----- We already have two guesses with opposite signs. --------------------------! funz = fun zside = .true. + !---------------------------------------------------------------------------------! else - if (abs(fun-funa) < 1.d2 * toler8 * tempa) then - delta = 1.d2 * toler8 * delta + !----- Need to find the guesses with opposite signs. -----------------------------! + if (abs(fun-funa) < 1.d2*toler8*tempa) then + delta = 1.d2*toler8*delta else - delta = max(abs(funa * (tempz-tempa)/(fun-funa)),1.d2 * toler8 * tempa) + delta = max(abs(funa * (tempz-tempa)/(fun-funa)),1.d2*toler8*tempa) end if + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! Try guesses on both sides of the first guess, increasingly further away ! + ! until we spot a good guess. ! + !---------------------------------------------------------------------------------! tempz = tempa + delta zside = .false. zgssloop: do itb=1,maxfpo @@ -895,11 +1433,22 @@ real(kind=8) function tsif8(pvap) if (zside) exit zgssloop end do zgssloop if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempa=',tempa,'funa=',funa - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempz=',tempz,'func=',funz + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the second guess:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' call fatal_error('Failed finding the second guess for regula falsi' & - ,'tsif8','therm_lib8.f90') + ,'tsif8','therm_lib8.f90') end if end if @@ -908,36 +1457,53 @@ real(kind=8) function tsif8(pvap) tsif8 = (funz*tempa-funa*tempz)/(funz-funa) !---------------------------------------------------------------------------------! - ! Now that we updated the guess, check whether they are really close. If so, ! + ! Now that we updated the guess, check whether they are really close. If so, ! ! it converged, I can use this as my guess. ! !---------------------------------------------------------------------------------! converged = abs(tsif8-tempa) < toler8 * tsif8 if (converged) exit bisloop + !---------------------------------------------------------------------------------! - !------ Finding the new function -------------------------------------------------! + !------ Find the new function evaluation. ----------------------------------------! fun = esif8(tsif8) - pvap + !---------------------------------------------------------------------------------! - !------ Defining my new interval based on the intermediate value theorem. --------! - if (fun*funa < 0. ) then + + !------ Define the new interval based on the intermediate value theorem. ---------! + if (fun*funa < 0.d0 ) then tempz = tsif8 funz = fun - !----- If we are updating zside again, modify aside (Illinois method) ---------! - if (zside) funa=funa * 5.d-1 - !----- We just updated zside, setting zside to true. --------------------------! + !----- If we are updating zside again, modify aside (Illinois method). --------! + if (zside) funa = funa * 5.d-1 + !----- We have just updated zside, so we set zside to true. -------------------! zside = .true. else tempa = tsif8 funa = fun - !----- If we are updating aside again, modify aside (Illinois method) ---------! - if (.not. zside) funz=funz * 5.d-1 - !----- We just updated aside, setting aside to true. --------------------------! + !----- If we are updating aside again, modify aside (Illinois method). --------! + if (.not. zside) funz = funz * 5.d-1 + !----- We have just updated aside, so we set zside to false. ------------------! zside = .false. end if end do bisloop if (.not.converged) then - call fatal_error('Temperature didn''t converge, giving up!!!' & - ,'tsif8','therm_lib8.f90') + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the solution:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' + call fatal_error('Temperature didn''t converge, we give up!!!' & + ,'tsif8','therm_lib8.f90') end if return @@ -956,29 +1522,40 @@ end function tsif8 ! This is truly the inverse of eslf and esif. ! !---------------------------------------------------------------------------------------! real(kind=8) function tslif8(pvap,useice) - use consts_coms, only: es3ple8 + use consts_coms, only : es3ple8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pvap - logical , intent(in), optional :: useice - logical :: brrr_cold - + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: pvap ! Vapour pressure [ Pa] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] + !----- Local variables. -------------------------------------------------------------! + logical :: frozen ! Will use ice thermodynamics [ T|F] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! - ! Since pvap is a function of temperature only, we can check the triple point ! + ! Since pvap is a function of temperature only, we can check the triple point ! ! from the saturation at the triple point, like what we would do for temperature. ! !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. pvap < es3ple8 + frozen = useice .and. pvap < es3ple8 else - brrr_cold = bulk_on .and. pvap < es3ple8 + frozen = bulk_on .and. pvap < es3ple8 end if + !------------------------------------------------------------------------------------! - if (brrr_cold) then + !------------------------------------------------------------------------------------! + ! Call the function depending on whether we should use ice. ! + !------------------------------------------------------------------------------------! + if (frozen) then tslif8 = tsif8(pvap) else tslif8 = tslf8(pvap) end if + !------------------------------------------------------------------------------------! return end function tslif8 @@ -993,19 +1570,34 @@ end function tslif8 !=======================================================================================! !=======================================================================================! ! This fucntion computes the dew point temperature given the pressure and vapour ! - ! mixing ratio. THIS IS DEWPOINT ONLY, WHICH MEANS THAT IT WILL IGNORE ICE EFFECT. For ! - ! a full, triple-point dependent routine use DEWFROSTPOINT ! + ! mixing ratio. THIS IS DEW POINT ONLY, WHICH MEANS THAT IT WILL IGNORE ICE EFFECT. For ! + ! a full, triple-point dependent routine use DEWFROSTPOINT. ! !---------------------------------------------------------------------------------------! real(kind=8) function dewpoint8(pres,rsat) - use consts_coms, only: ep8,toodry8 - + use consts_coms, only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pres, rsat - real(kind=8) :: rsatoff, pvsat - + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: rsatoff ! Non-singular saturation mixing ratio [ kg/kg] + real(kind=8) :: pvsat ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- Make sure mixing ratio is positive. ------------------------------------------! rsatoff = max(toodry8,rsat) - pvsat = pres*rsatoff / (ep8 + rsatoff) + !------------------------------------------------------------------------------------! + + + !----- Find the saturation vapour pressure. -----------------------------------------! + pvsat = pres * rsatoff / (ep8 + rsatoff) + !------------------------------------------------------------------------------------! + + !----- Dew point is going to be the saturation temperature. -------------------------! dewpoint8 = tslf8(pvsat) + !------------------------------------------------------------------------------------! return end function dewpoint8 @@ -1020,19 +1612,34 @@ end function dewpoint8 !=======================================================================================! !=======================================================================================! ! This fucntion computes the frost point temperature given the pressure and vapour ! - ! mixing ratio. THIS IS FROSTPOINT ONLY, WHICH MEANS THAT IT WILL IGNORE LIQUID EFFECT. ! - ! For a full, triple-point dependent routine use DEWFROSTPOINT ! + ! mixing ratio. THIS IS FROST POINT ONLY, WHICH MEANS THAT IT WILL IGNORE LIQUID ! + ! EFFECT. For a full, triple-point dependent routine use DEWFROSTPOINT. ! !---------------------------------------------------------------------------------------! real(kind=8) function frostpoint8(pres,rsat) - use consts_coms, only: ep8,toodry8 - + use consts_coms, only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pres, rsat - real(kind=8) :: rsatoff, pvsat - + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Local variables for iterative method. ----------------------------------------! + real(kind=8) :: rsatoff ! Non-singular saturation mixing ratio [ kg/kg] + real(kind=8) :: pvsat ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- Make sure mixing ratio is positive. ------------------------------------------! rsatoff = max(toodry8,rsat) + !------------------------------------------------------------------------------------! + + + !----- Find the saturation vapour pressure. -----------------------------------------! pvsat = pres*rsatoff / (ep8 + rsatoff) + !------------------------------------------------------------------------------------! + + !----- Frost point is going to be the saturation temperature. -----------------------! frostpoint8 = tsif8(pvsat) + !------------------------------------------------------------------------------------! return end function frostpoint8 @@ -1051,20 +1658,36 @@ end function frostpoint8 ! the triple point vapour pressure, finding dewpoint or frostpoint accordingly. ! !---------------------------------------------------------------------------------------! real(kind=8) function dewfrostpoint8(pres,rsat,useice) - use consts_coms, only: ep8,toodry8 + use consts_coms, only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: pres, rsat - logical , intent(in), optional :: useice - real(kind=8) :: rsatoff, pvsat + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: rsatoff ! Non-singular sat. mix. rat. [ kg/kg] + real(kind=8) :: pvsat ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- Make sure mixing ratio is positive. ------------------------------------------! + rsatoff = max(toodry8,rsat) + !------------------------------------------------------------------------------------! - rsatoff = max(toodry8,rsat) + !----- Find the saturation vapour pressure. -----------------------------------------! pvsat = pres*rsatoff / (ep8 + rsatoff) + !------------------------------------------------------------------------------------! + + !----- Dew (frost) point is going to be the saturation temperature. -----------------! if (present(useice)) then dewfrostpoint8 = tslif8(pvsat,useice) else dewfrostpoint8 = tslif8(pvsat) end if + !------------------------------------------------------------------------------------! return end function dewfrostpoint8 !=======================================================================================! @@ -1077,28 +1700,52 @@ end function dewfrostpoint8 !=======================================================================================! !=======================================================================================! - ! This function computes the vapour mixing ratio based on the pressure [Pa], tem- ! - ! perature [K] and relative humidity [fraction]. IT ALWAYS ASSUME THAT RELATIVE HUMI- ! - ! DITY IS WITH RESPECT TO THE LIQUID PHASE. ptrh2rvapil checks which one to use ! - ! depending on whether temperature is more or less than the triple point. ! + ! This function computes the vapour mixing ratio (or specific humidity) based on ! + ! the pressure [Pa], temperature [K] and relative humidity [fraction]. IT ALWAYS ! + ! ASSUMES THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE LIQUID PHASE. Ptrh2rvapil ! + ! checks which one to use depending on whether temperature is more or less than the ! + ! triple point. ! !---------------------------------------------------------------------------------------! - real(kind=8) function ptrh2rvapl8(relh,pres,temp) - use consts_coms, only: ep8,toodry8 - + real(kind=8) function ptrh2rvapl8(relh,pres,temp,out_shv) + use consts_coms, only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: relh, pres, temp - real(kind=8) :: rsath, relhh - rsath = max(toodry8,rslf8(pres,temp)) + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: relh ! Relative humidity [ --] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + logical , intent(in) :: out_shv ! Output is specific humidity [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: pvap ! Vapour pressure [ Pa] + real(kind=8) :: relhh ! Bounded relative humidity [ --] + !------------------------------------------------------------------------------------! + + + + !---- Make sure relative humidity is bounded. ---------------------------------------! relhh = min(1.d0,max(0.d0,relh)) + !------------------------------------------------------------------------------------! - if (newthermo) then - !----- Considering that Rel.Hum. is based on vapour pressure ---------------------! - ptrh2rvapl8 = max(toodry8,ep8 * relhh * rsath / (ep8 + (1.d0-relhh)*rsath)) + + !---- Find the vapour pressure. -----------------------------------------------------! + pvap = relhh * eslf8(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Convert the output to the sought humidity variable. ! + !------------------------------------------------------------------------------------! + if (out_shv) then + !----- Specific humidity. --------------------------------------------------------! + ptrh2rvapl8 = max(toodry8, ep8 * pvap / (pres - (1.d0 - ep8) * pvap)) + !---------------------------------------------------------------------------------! else - !----- Original RAMS way to compute mixing ratio ---------------------------------! - ptrh2rvapl8 = max(toodry8,relhh*rsath) + !----- Mixing ratio. -------------------------------------------------------------! + ptrh2rvapl8 = max(toodry8, ep8 * pvap / (pres - pvap)) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return end function ptrh2rvapl8 @@ -1112,33 +1759,57 @@ end function ptrh2rvapl8 !=======================================================================================! !=======================================================================================! - ! This function computes the vapour mixing ratio based on the pressure [Pa], tem- ! - ! perature [K] and relative humidity [fraction]. IT ALWAYS ASSUME THAT RELATIVE HUMI- ! - ! DITY IS WITH RESPECT TO THE ICE PHASE. ptrh2rvapil checks which one to use depending ! - ! on whether temperature is more or less than the triple point. ! + ! This function computes the vapour mixing ratio (or specific humidity) based on ! + ! the pressure [Pa], temperature [K] and relative humidity [fraction]. IT ALWAYS ! + ! ASSUMES THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE ICE PHASE. Ptrh2rvapil ! + ! checks which one to use depending on whether temperature is more or less than the ! + ! triple point. ! !---------------------------------------------------------------------------------------! - real(kind=8) function ptrh2rvapi8(relh,pres,temp) - use consts_coms, only: ep8,toodry8 - + real(kind=8) function ptrh2rvapi8(relh,pres,temp,out_shv) + use consts_coms, only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: relh, pres, temp - real(kind=8) :: rsath, relhh - - rsath = max(toodry8,rsif8(pres,temp)) - relhh = min(1.d0,max(0.d0,relh)) - if (newthermo) then - !----- Considering that Rel.Hum. is based on vapour pressure ---------------------! - ptrh2rvapi8 = max(toodry8,ep8 * relhh * rsath / (ep8 + (1.d0-relhh)*rsath)) - else - !----- Original RAMS way to compute mixing ratio ---------------------------------! - ptrh2rvapi8 = max(toodry8,relhh*rsath) - end if + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: relh ! Relative humidity [ --] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + logical , intent(in) :: out_shv ! Output is specific humidity [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: pvap ! Vapour pressure [ Pa] + real(kind=8) :: relhh ! Bounded relative humidity [ --] + !------------------------------------------------------------------------------------! - return - end function ptrh2rvapi8 - !=======================================================================================! - !=======================================================================================! + + + !---- Make sure relative humidity is bounded. ---------------------------------------! + relhh = min(1.d0,max(0.d0,relh)) + !------------------------------------------------------------------------------------! + + + !---- Find the vapour pressure. -----------------------------------------------------! + pvap = relhh * esif8(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Convert the output to the sought humidity variable. ! + !------------------------------------------------------------------------------------! + if (out_shv) then + !----- Specific humidity. --------------------------------------------------------! + ptrh2rvapi8 = max(toodry8, ep8 * pvap / (pres - (1.d0 - ep8) * pvap)) + !---------------------------------------------------------------------------------! + else + !----- Mixing ratio. -------------------------------------------------------------! + ptrh2rvapi8 = max(toodry8, ep8 * pvap / (pres - pvap)) + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + return + end function ptrh2rvapi8 + !=======================================================================================! + !=======================================================================================! @@ -1147,36 +1818,67 @@ end function ptrh2rvapi8 !=======================================================================================! !=======================================================================================! - ! This function computes the vapour mixing ratio based on the pressure [Pa], tem- ! - ! perature [K] and relative humidity [fraction]. It will check the temperature to ! - ! decide between ice or liquid saturation and whether ice should be considered. ! + ! This function computes the vapour mixing ratio based (or specific humidity) based ! + ! on the pressure [Pa], temperature [K] and relative humidity [fraction]. It checks ! + ! the temperature to decide between ice or liquid saturation. ! !---------------------------------------------------------------------------------------! - real(kind=8) function ptrh2rvapil8(relh,pres,temp,useice) - use consts_coms, only: ep8,toodry8,t3ple8 + real(kind=8) function ptrh2rvapil8(relh,pres,temp,out_shv,useice) + use consts_coms, only : ep8 & ! intent(in) + , toodry8 & ! intent(in) + , t3ple8 ! ! intent(in) implicit none - real(kind=8), intent(in) :: relh, pres, temp - logical , intent(in), optional :: useice - real(kind=8) :: rsath, relhh - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: relh ! Relative humidity [ --] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + logical , intent(in) :: out_shv ! Output is specific humidity [ T|F] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: pvap ! Vapour pressure [ Pa] + real(kind=8) :: relhh ! Bounded relative humidity [ --] + logical :: frozen ! Will use ice thermodynamics [ T|F] + !------------------------------------------------------------------------------------! - !----- Checking whether I use the user or the default check for ice saturation. -----! + + !----- Check whether to use the user's or the default flag for ice saturation. ------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple8 + frozen = useice .and. temp < t3ple8 else - brrr_cold = bulk_on .and. temp < t3ple8 + frozen = bulk_on .and. temp < t3ple8 end if + !------------------------------------------------------------------------------------! + + + + !---- Make sure relative humidity is bounded. ---------------------------------------! + relhh = min(1.d0,max(0.d0,relh)) + !------------------------------------------------------------------------------------! + - if (brrr_cold) then - rsath = max(toodry8,rsif8(pres,temp)) + !---- Find the vapour pressure (ice or liquid, depending on the value of frozen). ---! + if (frozen) then + pvap = relhh * esif8(temp) else - rsath = max(toodry8,rslf8(pres,temp)) + pvap = relhh * eslf8(temp) end if + !------------------------------------------------------------------------------------! - relhh = min(1.d0,max(0.d0,relh)) - - ptrh2rvapil8 = max(toodry8,ep8 * relhh * rsath / (ep8 + (1.d0-relhh)*rsath)) + !------------------------------------------------------------------------------------! + ! Convert the output to the sought humidity variable. ! + !------------------------------------------------------------------------------------! + if (out_shv) then + !----- Specific humidity. --------------------------------------------------------! + ptrh2rvapil8 = max(toodry8, ep8 * pvap / (pres - (1.d0 - ep8) * pvap)) + !---------------------------------------------------------------------------------! + else + !----- Mixing ratio. -------------------------------------------------------------! + ptrh2rvapil8 = max(toodry8, ep8 * pvap / (pres - pvap)) + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! return end function ptrh2rvapil8 !=======================================================================================! @@ -1190,32 +1892,51 @@ end function ptrh2rvapil8 !=======================================================================================! !=======================================================================================! ! This function computes the relative humidity [fraction] based on pressure, tem- ! - ! perature, and vapour mixing ratio. Two important points: ! + ! perature, and vapour mixing ratio (or specific humidity). Two important points: ! ! 1. IT ALWAYS ASSUME THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE LIQUID PHASE. ! ! If you want to switch between ice and liquid, use rehuil instead. ! ! 2. IT DOESN'T PREVENT SUPERSATURATION TO OCCUR. This is because this subroutine is ! ! also used in the microphysics, where supersaturation does happen and needs to be ! ! accounted. ! !---------------------------------------------------------------------------------------! - real(kind=8) function rehul8(pres,temp,rvpr) - use consts_coms, only: ep8,toodry8 + real(kind=8) function rehul8(pres,temp,humi,is_shv) + use consts_coms, only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: pres ! Air pressure [ Pa] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rvpr ! Vapour mixing ratio [ kg/kg] + real(kind=8), intent(in) :: pres ! Air pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: humi ! Humidity [ kg/kg] + logical , intent(in) :: is_shv ! Input humidity is specific humidity [ T|F] !----- Local variables --------------------------------------------------------------! - real(kind=8) :: rvprsat ! Saturation mixing ratio [ kg/kg] + real(kind=8) :: shv ! Specific humidity [ kg/kg] + real(kind=8) :: pvap ! Vapour pressure [ Pa] + real(kind=8) :: psat ! Saturation vapour pressure [ Pa] !------------------------------------------------------------------------------------! - rvprsat = max(toodry8,rslf8(pres,temp)) - if (newthermo) then - !----- This is based on relative humidity being defined with vapour pressure -----! - rehul8 = max(0.d0,rvpr*(ep8+rvprsat)/(rvprsat*(ep8+rvpr))) + + !---- Make sure that we have specific humidity. -------------------------------------! + if (is_shv) then + shv = max(toodry8,humi) else - !----- Original formula used by RAMS ---------------------------------------------! - rehul8 = max(0.d0,rvpr/rvprsat) + shv = max(toodry8,humi) / ( 1.d0 + max(toodry8,humi) ) end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the vapour pressure and the saturation vapour pressure. ! + !------------------------------------------------------------------------------------! + pvap = ( pres * shv ) / ( ep8 + (1.d0 - ep8) * shv ) + psat = eslf8(temp) + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Find the relative humidity. ! + !------------------------------------------------------------------------------------! + rehul8 = max(0.d0 , pvap / psat) + !------------------------------------------------------------------------------------! + return end function rehul8 !=======================================================================================! @@ -1229,32 +1950,51 @@ end function rehul8 !=======================================================================================! !=======================================================================================! ! This function computes the relative humidity [fraction] based on pressure, tem- ! - ! perature, and vapour mixing ratio. Two important points: ! + ! perature, and vapour mixing ratio (or specific humidity). Two important points: ! ! 1. IT ALWAYS ASSUME THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE ICE PHASE. ! ! If you want to switch between ice and liquid, use rehuil instead. ! ! 2. IT DOESN'T PREVENT SUPERSATURATION TO OCCUR. This is because this subroutine is ! ! also used in the microphysics, where supersaturation does happen and needs to be ! ! accounted. ! !---------------------------------------------------------------------------------------! - real(kind=8) function rehui8(pres,temp,rvpr) - use consts_coms, only: ep8,toodry8 + real(kind=8) function rehui8(pres,temp,humi,is_shv) + use consts_coms, only : ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: pres ! Air pressure [ Pa] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rvpr ! Vapour mixing ratio [ kg/kg] + real(kind=8), intent(in) :: pres ! Air pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: humi ! Humidity [ kg/kg] + logical , intent(in) :: is_shv ! Input humidity is specific humidity [ T|F] !----- Local variables --------------------------------------------------------------! - real(kind=8) :: rvprsat ! Saturation mixing ratio [ kg/kg] + real(kind=8) :: shv ! Specific humidity [ kg/kg] + real(kind=8) :: pvap ! Vapour pressure [ Pa] + real(kind=8) :: psat ! Saturation vapour pressure [ Pa] !------------------------------------------------------------------------------------! - rvprsat = max(toodry8,rsif8(pres,temp)) - if (newthermo) then - !----- This is based on relative humidity being defined with vapour pressure -----! - rehui8 = max(0.d0,rvpr*(ep8+rvprsat)/(rvprsat*(ep8+rvpr))) + + !---- Make sure that we have specific humidity. -------------------------------------! + if (is_shv) then + shv = max(toodry8,humi) else - !----- Original formula used by RAMS ---------------------------------------------! - rehui8 = max(0.d0,rvpr/rvprsat) + shv = max(toodry8,humi) / ( 1.d0 + max(toodry8,humi) ) end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the vapour pressure and the saturation vapour pressure. ! + !------------------------------------------------------------------------------------! + pvap = ( pres * shv ) / ( ep8 + (1.d0 - ep8) * shv ) + psat = esif8(temp) + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Find the relative humidity. ! + !------------------------------------------------------------------------------------! + rehui8 = max(0.d0 , pvap / psat) + !------------------------------------------------------------------------------------! + return end function rehui8 !=======================================================================================! @@ -1268,7 +2008,7 @@ end function rehui8 !=======================================================================================! !=======================================================================================! ! This function computes the relative humidity [fraction] based on pressure, tem- ! - ! perature, and vapour mixing ratio. Two important points: ! + ! perature, and vapour mixing ratio (or specific humidity). Two important points: ! ! 1. It may consider whether the temperature is above or below the freezing point ! ! to choose which saturation to use. It is possible to explicitly force not to use ! ! ice in case level is 2 or if you have reasons not to use ice (e.g. reading data ! @@ -1277,33 +2017,61 @@ end function rehui8 ! also used in the microphysics, where supersaturation does happen and needs to be ! ! accounted. ! !---------------------------------------------------------------------------------------! - real(kind=8) function rehuil8(pres,temp,rvap,useice) - use consts_coms, only: t3ple8 + real(kind=8) function rehuil8(pres,temp,humi,is_shv,useice) + use consts_coms, only : t3ple8 & ! intent(in) + , ep8 & ! intent(in) + , toodry8 ! ! intent(in) implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: pres ! Air pressure [ Pa] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] - logical , intent(in), optional :: useice ! Should I consider ice? [ T|F] + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Air pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: humi ! Humidity [ kg/kg] + logical , intent(in) :: is_shv ! Input is specific humidity [ T|F] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] !----- Local variables --------------------------------------------------------------! - real(kind=8) :: rvapsat ! Saturation mixing ratio [ kg/kg] - logical :: brrr_cold ! I'll use ice sat. now [ T|F] + real(kind=8) :: shv ! Specific humidity [ kg/kg] + real(kind=8) :: pvap ! Vapour pressure [ Pa] + real(kind=8) :: psat ! Saturation vapour pressure [ Pa] + logical :: frozen ! Will use ice saturation now [ T|F] !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! - ! Checking whether I should go with ice or liquid saturation. ! + ! Check whether we should use ice or liquid saturation. ! !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple8 + frozen = useice .and. temp < t3ple8 else - brrr_cold = bulk_on .and. temp < t3ple8 + frozen = bulk_on .and. temp < t3ple8 + end if + !------------------------------------------------------------------------------------! + + + !---- Make sure that we have specific humidity. -------------------------------------! + if (is_shv) then + shv = max(toodry8,humi) + else + shv = max(toodry8,humi) / ( 1.d0 + max(toodry8,humi) ) end if + !------------------------------------------------------------------------------------! + - if (brrr_cold) then - rehuil8 = rehui8(pres,temp,rvap) + !------------------------------------------------------------------------------------! + ! Find the vapour pressure and the saturation vapour pressure. ! + !------------------------------------------------------------------------------------! + pvap = ( pres * shv ) / ( ep8 + (1.d0 - ep8) * shv ) + if (frozen) then + psat = esif8(temp) else - rehuil8 = rehul8(pres,temp,rvap) + psat = esif8(temp) end if + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Find the relative humidity. ! + !------------------------------------------------------------------------------------! + rehuil8 = max(0.d0 ,pvap / psat) + !------------------------------------------------------------------------------------! return end function rehuil8 @@ -1323,23 +2091,33 @@ end function rehuil8 ! 2. This can be used for virtual potential temperature, just give potential tempera- ! ! ture instead of temperature. ! !---------------------------------------------------------------------------------------! - real(kind=8) function tv2temp8(tvir,rvpr,rtot) - use consts_coms, only: epi8 + real(kind=8) function tv2temp8(tvir,rvap,rtot) + use consts_coms, only : epi8 ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! real(kind=8), intent(in) :: tvir ! Virtual temperature [ K] - real(kind=8), intent(in) :: rvpr ! Vapour mixing ratio [kg/kg] + real(kind=8), intent(in) :: rvap ! Vapour mixing ratio [kg/kg] real(kind=8), intent(in), optional :: rtot ! Total mixing ratio [kg/kg] - !----- Local variable ---------------------------------------------------------------! - real :: rtothere ! Internal rtot [kg/kg] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: rtothere ! Total or vapour mixing ratio [kg/kg] + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Prefer using total mixing ratio, but if it isn't provided, then use vapour ! + ! as total (no condensation). ! + !------------------------------------------------------------------------------------! if (present(rtot)) then rtothere = rtot else - rtothere = rvpr + rtothere = rvap end if + !------------------------------------------------------------------------------------! - tv2temp8 = tvir * (1.d0 + rtothere) / (1.d0 + epi8*rvpr) + + !----- Convert using a generalised function. ----------------------------------------! + tv2temp8 = tvir * (1.d0 + rtothere) / (1.d0 + epi8 * rvap) + !------------------------------------------------------------------------------------! return end function tv2temp8 @@ -1359,23 +2137,33 @@ end function tv2temp8 ! 2. This can be used for virtual potential temperature, just give potential tempera- ! ! ture instead of temperature. ! !---------------------------------------------------------------------------------------! - real(kind=8) function virtt8(temp,rvpr,rtot) - use consts_coms, only: epi8 + real(kind=8) function virtt8(temp,rvap,rtot) + use consts_coms, only: epi8 ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rvpr ! Vapour mixing ratio [kg/kg] + real(kind=8), intent(in) :: rvap ! Vapour mixing ratio [kg/kg] real(kind=8), intent(in), optional :: rtot ! Total mixing ratio [kg/kg] !----- Local variable ---------------------------------------------------------------! - real :: rtothere ! Internal rtot, to deal with optional [kg/kg] + real(kind=8) :: rtothere ! Total or vapour mixing ratio [kg/kg] + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Prefer using total mixing ratio, but if it isn't provided, then use vapour ! + ! as total (no condensation). ! + !------------------------------------------------------------------------------------! if (present(rtot)) then rtothere = rtot else - rtothere = rvpr + rtothere = rvap end if + !------------------------------------------------------------------------------------! + - virtt8 = temp * (1.d0 + epi8 * rvpr) / (1.d0 + rtothere) + !----- Convert using a generalised function. ----------------------------------------! + virtt8 = temp * (1.d0 + epi8 * rvap) / (1.d0 + rtothere) + !------------------------------------------------------------------------------------! return end function virtt8 @@ -1393,24 +2181,34 @@ end function virtt8 ! gas law. The condensed phase will be taken into account if the user provided both ! ! the vapour and the total mixing ratios. ! !---------------------------------------------------------------------------------------! - real(kind=8) function idealdens8(pres,temp,rvpr,rtot) - use consts_coms, only: rdry8 + real(kind=8) function idealdens8(pres,temp,rvap,rtot) + use consts_coms, only : rdry8 ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rvpr ! Vapour mixing ratio [kg/kg] - real(kind=8), intent(in), optional :: rtot ! Total mixing ratio [kg/kg] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] + real(kind=8), intent(in), optional :: rtot ! Total mixing ratio [ kg/kg] !----- Local variable ---------------------------------------------------------------! - real(kind=8) :: tvir ! Virtual temperature [ K] + real(kind=8) :: tvir ! Virtual temperature [ K] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Prefer using total mixing ratio, but if it isn't provided, then use vapour ! + ! as total (no condensation). ! !------------------------------------------------------------------------------------! if (present(rtot)) then - tvir = virtt8(temp,rvpr,rtot) + tvir = virtt8(temp,rvap,rtot) else - tvir = virtt8(temp,rvpr) + tvir = virtt8(temp,rvap) end if + !------------------------------------------------------------------------------------! + + !----- Convert using the definition of virtual temperature. -------------------------! idealdens8 = pres / (rdry8 * tvir) + !------------------------------------------------------------------------------------! return end function idealdens8 @@ -1433,21 +2231,30 @@ real(kind=8) function idealdenssh8(pres,temp,qvpr,qtot) , epi8 ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: qvpr ! Vapour specific mass [kg/kg] - real(kind=8), intent(in), optional :: qtot ! Total water specific mass [kg/kg] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: qvpr ! Vapour specific mass [ kg/kg] + real(kind=8), intent(in), optional :: qtot ! Total water specific mass [ kg/kg] !----- Local variables. -------------------------------------------------------------! - real(kind=8) :: qall ! Either qtot or qvpr... [kg/kg] + real(kind=8) :: qall ! Either qtot or qvpr... [ kg/kg] !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Prefer using total specific humidity, but if it isn't provided, then use ! + ! vapour phase as the total (no condensation). ! + !------------------------------------------------------------------------------------! if (present(qtot)) then qall = qtot else qall = qvpr end if + !------------------------------------------------------------------------------------! + + !----- Convert using a generalised function. ----------------------------------------! idealdenssh8 = pres / (rdry8 * temp * (1.d0 - qall + epi8 * qvpr)) + !------------------------------------------------------------------------------------! return end function idealdenssh8 @@ -1462,27 +2269,28 @@ end function idealdenssh8 !=======================================================================================! !=======================================================================================! ! This function computes reduces the pressure from the reference height to the ! - ! canopy height by assuming hydrostatic equilibrium. ! + ! canopy height by assuming hydrostatic equilibrium. For simplicity, we assume that ! + ! R and cp are constants (in reality they are dependent on humidity). ! !---------------------------------------------------------------------------------------! real(kind=8) function reducedpress8(pres,thetaref,shvref,zref,thetacan,shvcan,zcan) use consts_coms, only : epim18 & ! intent(in) , p00k8 & ! intent(in) , rocp8 & ! intent(in) , cpor8 & ! intent(in) - , cp8 & ! intent(in) + , cpdry8 & ! intent(in) , grav8 ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: thetaref ! Potential temperature [ K] - real(kind=8), intent(in) :: shvref ! Vapour specific mass [ kg/kg] - real(kind=8), intent(in) :: zref ! Height at reference level [ m] - real(kind=8), intent(in) :: thetacan ! Potential temperature [ K] - real(kind=8), intent(in) :: shvcan ! Vapour specific mass [ kg/kg] - real(kind=8), intent(in) :: zcan ! Height at canopy level [ m] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: thetaref ! Potential temperature [ K] + real(kind=8), intent(in) :: shvref ! Vapour specific mass [ kg/kg] + real(kind=8), intent(in) :: zref ! Height at reference level [ m] + real(kind=8), intent(in) :: thetacan ! Potential temperature [ K] + real(kind=8), intent(in) :: shvcan ! Vapour specific mass [ kg/kg] + real(kind=8), intent(in) :: zcan ! Height at canopy level [ m] !------Local variables. -------------------------------------------------------------! - real(kind=8) :: pinc ! Pressure increment [ Pa^(R/cp)] - real(kind=8) :: thvbar ! Average virtual pot. temper. [ K] + real(kind=8) :: pinc ! Pressure increment [ Pa^R/cp] + real(kind=8) :: thvbar ! Average virtual pot. temperature [ K] !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! @@ -1490,13 +2298,19 @@ real(kind=8) function reducedpress8(pres,thetaref,shvref,zref,thetacan,shvcan,zc ! top and the reference level. ! !------------------------------------------------------------------------------------! thvbar = 5.d-1 * ( thetaref * (1.d0 + epim18 * shvref) & - + thetacan * (1.d0 + epim18 * shvcan)) + + thetacan * (1.d0 + epim18 * shvcan) ) + !------------------------------------------------------------------------------------! + + !----- Then, we find the pressure gradient scale. -----------------------------------! - pinc = grav8 * p00k8 * (zref - zcan) / (cp8 * thvbar) + pinc = grav8 * p00k8 * (zref - zcan) / (cpdry8 * thvbar) + !------------------------------------------------------------------------------------! + !----- And we can find the reduced pressure. ----------------------------------------! reducedpress8 = (pres**rocp8 + pinc ) ** cpor8 + !------------------------------------------------------------------------------------! return end function reducedpress8 @@ -1508,50 +2322,31 @@ end function reducedpress8 + !=======================================================================================! !=======================================================================================! - ! This function computes the enthalpy given the pressure, temperature, vapour ! - ! specific humidity, and height. Currently it doesn't compute mixed phase air, but ! - ! adding it should be straight forward (finding the inverse is another story...). ! + ! This function computes the Exner function [J/kg/K], given the pressure. It ! + ! assumes for simplicity that R and Cp are constants and equal to the dry air values. ! !---------------------------------------------------------------------------------------! - real(kind=8) function ptqz2enthalpy8(pres,temp,qvpr,zref) - use consts_coms, only : ep8 & ! intent(in) - , grav8 & ! intent(in) - , t3ple8 & ! intent(in) - , eta3ple8 & ! intent(in) - , cimcp8 & ! intent(in) - , clmcp8 & ! intent(in) - , cp8 & ! intent(in) - , alvi8 ! ! intent(in) + real(kind=8) function press2exner8(pres) + use consts_coms, only : p00i8 & ! intent(in) + , cpdry8 & ! intent(in) + , rocp8 ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: qvpr ! Vapour specific mass [ kg/kg] - real(kind=8), intent(in) :: zref ! Reference height [ m] - !------Local variables. -------------------------------------------------------------! - real(kind=8) :: tequ ! Dew-frost temperature [ K] - real(kind=8) :: pequ ! Equlibrium vapour pressure [ Pa] + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: pres ! Pressure [ Pa] !------------------------------------------------------------------------------------! - !----- First, we find the equilibrium vapour pressure and dew/frost point. ----------! - pequ = pres * qvpr / (ep8 + (1.d0 - ep8) * qvpr) - tequ = tslif8(pequ) !------------------------------------------------------------------------------------! - ! Then, based on dew/frost point, we compute the enthalpy. This accounts whether ! - ! we would have to dew or frost formation if the temperature dropped to the ! - ! equilibrium point. Notice that if supersaturation exists, this will still give a ! - ! number that makes sense, similar to the internal energy of supercooled water. ! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + press2exner8 = cpdry8 * ( pres * p00i8 ) ** rocp8 !------------------------------------------------------------------------------------! - if (tequ <= t3ple8) then - ptqz2enthalpy8 = cp8 * temp + qvpr * (cimcp8 * tequ + alvi8 ) + grav8 * zref - else - ptqz2enthalpy8 = cp8 * temp + qvpr * (clmcp8 * tequ + eta3ple8) + grav8 * zref - end if return - end function ptqz2enthalpy8 + end function press2exner8 !=======================================================================================! !=======================================================================================! @@ -1560,52 +2355,32 @@ end function ptqz2enthalpy8 + !=======================================================================================! !=======================================================================================! - ! This function computes the temperature given the enthalpy, pressure, vapour ! - ! specific humidity, and reference height. Currently it doesn't compute mixed phase ! - ! air, but adding it wouldn't be horribly hard, though it would require some root ! - ! finding. ! + ! This function computes the pressure [Pa], given the Exner function. Like in the ! + ! function above, we also assume R and Cp to be constants and equal to the dry air ! + ! values. ! !---------------------------------------------------------------------------------------! - real(kind=8) function hpqz2temp8(enthalpy,pres,qvpr,zref) - use consts_coms, only : ep8 & ! intent(in) - , grav8 & ! intent(in) - , t3ple8 & ! intent(in) - , eta3ple8 & ! intent(in) - , cimcp8 & ! intent(in) - , clmcp8 & ! intent(in) - , cpi8 & ! intent(in) - , alvi8 ! ! intent(in) + real(kind=8) function exner2press8(exner) + use consts_coms, only : p008 & ! intent(in) + , cpdryi8 & ! intent(in) + , cpor8 ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: enthalpy ! Enthalpy... [ J/kg] - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: qvpr ! Vapour specific mass [ kg/kg] - real(kind=8), intent(in) :: zref ! Reference height [ m] - !------Local variables. -------------------------------------------------------------! - real(kind=8) :: tequ ! Dew-frost temperature [ K] - real(kind=8) :: pequ ! Equlibrium vapour pressure [ Pa] + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: exner ! Exner function [ J/kg/K] !------------------------------------------------------------------------------------! - !----- First, we find the equilibrium vapour pressure and dew/frost point. ----------! - pequ = pres * qvpr / (ep8 + (1.d0 - ep8) * qvpr) - tequ = tslif8(pequ) !------------------------------------------------------------------------------------! - ! Then, based on dew/frost point, we compute the temperature. This accounts ! - ! whether we would have to dew or frost formation if the temperature dropped to the ! - ! equilibrium point. Notice that if supersaturation exists, this will still give a ! - ! temperature that makes sense (but less than the dew/frost point), similar to the ! - ! internal energy of supercooled water. ! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + exner2press8 = p008 * ( exner * cpdryi8 ) ** cpor8 !------------------------------------------------------------------------------------! - if (tequ <= t3ple8) then - hpqz2temp8 = cpi8 * (enthalpy - qvpr * (cimcp8 * tequ + alvi8 ) - grav8 * zref) - else - hpqz2temp8 = cpi8 * (enthalpy - qvpr * (clmcp8 * tequ + eta3ple8) - grav8 * zref) - end if return - end function hpqz2temp8 + end function exner2press8 !=======================================================================================! !=======================================================================================! @@ -1614,31 +2389,31 @@ end function hpqz2temp8 + !=======================================================================================! !=======================================================================================! - ! This function finds the temperature given the potential temperature, density, and ! - ! specific humidity. This comes from a combination of the definition of potential ! - ! temperature and the ideal gas law, to eliminate pressure, when pressure is also ! - ! unknown. ! + ! This function computes the potential temperature [K], given the Exner function ! + ! and temperature. For simplicity we ignore the effects of humidity in R and cp and ! + ! use the dry air values instead. ! !---------------------------------------------------------------------------------------! - real(kind=8) function thrhsh2temp8(theta,dens,qvpr) - use consts_coms, only : cpocv8 & ! intent(in) - , p00i8 & ! intent(in) - , rdry8 & ! intent(in) - , epim18 & ! intent(in) - , rocv8 ! ! intent(in) + real(kind=8) function extemp2theta8(exner,temp) + use consts_coms, only : cpdry8 ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: theta ! Potential temperature [ K] - real(kind=8), intent(in) :: dens ! Density [ Pa] - real(kind=8), intent(in) :: qvpr ! Specific humidity [ kg/kg] + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: exner ! Exner function [ J/kg/K] + real(kind=8), intent(in) :: temp ! Temperature [ K] !------------------------------------------------------------------------------------! - thrhsh2temp8 = theta ** cpocv8 & - * (p00i8 * dens * rdry8 * (1.d0 + epim18 * qvpr)) ** rocv8 + + !------------------------------------------------------------------------------------! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + extemp2theta8 = cpdry8 * temp / exner + !------------------------------------------------------------------------------------! return - end function thrhsh2temp8 + end function extemp2theta8 !=======================================================================================! !=======================================================================================! @@ -1647,48 +2422,32 @@ end function thrhsh2temp8 + !=======================================================================================! !=======================================================================================! - ! This fucntion computes the ice liquid potential temperature given the Exner ! - ! function [J/kg/K], temperature [K], and liquid and ice mixing ratios [kg/kg]. ! + ! This function computes the temperature [K], given the Exner function and ! + ! potential temperature. We simplify the equations by assuming that R and Cp are ! + ! constants. ! !---------------------------------------------------------------------------------------! - real(kind=8) function theta_iceliq8(exner,temp,rliq,rice) - use consts_coms, only: alvl8, alvi8, cp8, ttripoli8, htripoli8, htripolii8 + real(kind=8) function extheta2temp8(exner,theta) + use consts_coms, only : p00i8 & ! intent(in) + , cpdryi8 ! ! intent(in) implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: exner ! Exner function [J/kg/K] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] - real(kind=8), intent(in) :: rice ! Ice mixing ratio [ kg/kg] - !----- Local variables --------------------------------------------------------------! - real(kind=8) :: hh ! Enthalpy associated with sensible heat [ J/kg] - real(kind=8) :: qq ! Enthalpy associated with latent heat [ J/kg] + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: exner ! Exner function [ J/kg/K] + real(kind=8), intent(in) :: theta ! Potential temperature [ K] !------------------------------------------------------------------------------------! - !----- Finding the enthalpies -------------------------------------------------------! - hh = cp8 * temp - qq = alvl8*rliq + alvi8 * rice - - if (newthermo) then - - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli8) then - theta_iceliq8 = hh * exp(-qq/hh) / exner - else - theta_iceliq8 = hh * exp(-qq * htripolii8) / exner - end if - else - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli8) then - theta_iceliq8 = hh * hh / (exner * ( hh + qq)) - else - theta_iceliq8 = hh * htripoli8 / (exner * ( htripoli8 + qq)) - end if - end if + + !------------------------------------------------------------------------------------! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + extheta2temp8 = cpdryi8 * exner * theta + !------------------------------------------------------------------------------------! return - end function theta_iceliq8 + end function extheta2temp8 !=======================================================================================! !=======================================================================================! @@ -1697,82 +2456,34 @@ end function theta_iceliq8 + !=======================================================================================! !=======================================================================================! - ! This function computes the liquid potential temperature derivative with respect ! - ! to temperature, useful in iterative methods. ! + ! This function computes the specific internal energy of water [J/kg], given the ! + ! temperature and liquid fraction. ! !---------------------------------------------------------------------------------------! - real(kind=8) function dthetail_dt8(condconst,thil,exner,pres,temp,rliq,ricein) - use consts_coms, only: alvl8, alvi8, cp8, ttripoli8,htripoli8,htripolii8,t3ple8 - + real(kind=8) function tl2uint8(temp,fliq) + use consts_coms, only : cice8 & ! intent(in) + , cliq8 & ! intent(in) + , tsupercool_liq8 ! ! intent(in) + implicit none !----- Arguments --------------------------------------------------------------------! - logical , intent(in) :: condconst ! Condensation is constant? [ T|F] - real(kind=8), intent(in) :: thil ! Ice liquid pot. temp. [ K] - real(kind=8), intent(in) :: exner ! Exner function [J/kg/K] - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] - real(kind=8), intent(in), optional :: ricein ! Ice mixing ratio [ kg/kg] - !----- Local variables --------------------------------------------------------------! - real(kind=8) :: rice ! Ice mixing ratio or 0. [ kg/kg] - real(kind=8) :: ldrst ! L × d(rs)/dT × T [ J/kg] - real(kind=8) :: hh ! Sensible heat enthalpy [ J/kg] - real(kind=8) :: qq ! Latent heat enthalpy [ J/kg] - logical :: thereisice ! Is ice present [ ---] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: fliq ! Fraction liquid water [ kg/kg] !------------------------------------------------------------------------------------! - + + + !------------------------------------------------------------------------------------! - ! Checking whether I should consider ice or not. ! + ! Internal energy is given by the sum of internal energies of ice and liquid ! + ! phases. ! + !------------------------------------------------------------------------------------! + tl2uint8 = (1.d0 - fliq) * cice8 * temp + fliq * cliq8 * (temp - tsupercool_liq8) !------------------------------------------------------------------------------------! - thereisice = present(ricein) - - if (thereisice) then - rice=ricein - else - rice=0.d0 - end if - - !----- No condensation, dthetail_dt is a constant -----------------------------------! - if (rliq+rice == 0.d0) then - dthetail_dt8 = thil/temp - return - else - hh = cp8 * temp !----- Sensible heat enthalpy - qq = alvl8* rliq + alvi8 * rice !----- Latent heat enthalpy - !---------------------------------------------------------------------------------! - ! This is the term L×[d(rs)/dt]×T. L may be either the vapourisation or ! - ! sublimation latent heat, depending on the temperature and whether we are consi- ! - ! dering ice or not. Also, if condensation mixing ratio is constant, then this ! - ! term will be always zero. ! - !---------------------------------------------------------------------------------! - if (condconst) then - ldrst = 0.d0 - elseif (thereisice .and. temp < t3ple8) then - ldrst = alvi8*rsifp8(pres,temp)*temp - else - ldrst = alvl8*rslfp8(pres,temp)*temp - end if - end if - - if (newthermo) then - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli8) then - dthetail_dt8 = thil * (1. + (ldrst + qq)/hh) / temp - else - dthetail_dt8 = thil * (1. + ldrst*htripolii8) / temp - end if - else - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli8) then - dthetail_dt8 = thil * (1.d0 + (ldrst + qq)/(hh+qq)) / temp - else - dthetail_dt8 = thil * (1.d0 + ldrst/(htripoli8 + alvl8*rliq)) / temp - end if - end if return - end function dthetail_dt8 + end function tl2uint8 !=======================================================================================! !=======================================================================================! @@ -1781,239 +2492,93 @@ end function dthetail_dt8 + !=======================================================================================! !=======================================================================================! - ! This function computes temperature from the ice-liquid water potential temperature ! - ! in Kelvin, Exner function in J/kg/K, and liquid and ice mixing ratios in kg/kg. ! - ! For now t1stguess is used only to decide whether I should use the complete case or ! - ! the 253 K to reduce the error on neglecting the changes on latent heat due to temper- ! - ! ature. ! + ! This function computes the internal energy of water [J/m²] or [ J/m³], given the ! + ! temperature [K], the heat capacity of the "dry" part [J/m²/K] or [J/m³/K], water mass ! + ! [ kg/m²] or [ kg/m³], and liquid fraction [---]. ! !---------------------------------------------------------------------------------------! - real(kind=8) function thil2temp8(thil,exner,pres,rliq,rice,t1stguess) - use consts_coms, only : cp8 & ! intent(in) - , cpi8 & ! intent(in) - , alvl8 & ! intent(in) - , alvi8 & ! intent(in) - , t008 & ! intent(in) - , t3ple8 & ! intent(in) - , ttripoli8 & ! intent(in) - , htripolii8 & ! intent(in) - , cpi48 ! ! intent(in) + real(kind=8) function cmtl2uext8(dryhcap,wmass,temp,fliq) + use consts_coms, only : cice8 & ! intent(in) + , cliq8 & ! intent(in) + , tsupercool_liq8 ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: thil ! Ice-liquid water potential temp. [ K] - real(kind=8), intent(in) :: exner ! Exner function [J/kg/K] - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] - real(kind=8), intent(in) :: rice ! Ice mixing ratio [ kg/kg] - real(kind=8), intent(in) :: t1stguess ! 1st. guess for temperature [ K] - !----- Local variables for iterative method -----------------------------------------! - real(kind=8) :: deriv ! Function derivative - real(kind=8) :: fun ! Function for which we seek a root. - real(kind=8) :: funa ! Smallest guess function - real(kind=8) :: funz ! Largest guess function - real(kind=8) :: tempa ! Smallest guess (or previous guess in Newton) - real(kind=8) :: tempz ! Largest guess (or new guess in Newton) - real(kind=8) :: delta ! Aux. var to compute 2nd guess for bisection - integer :: itn,itb ! Iteration counter - logical :: converged ! Convergence handle - logical :: zside ! Flag to check for one-sided approach... - real(kind=8) :: til ! Ice liquid temperature [ K] - !------------------------------------------------------------------------------------! - - - !----- 1st. of all, check whether there is condensation. If not, theta_il = theta ---! - if (rliq+rice == 0.d0) then - thil2temp8 = cpi8 * thil * exner - return - !----- If not, check whether we are using the old thermo or the new one -------------! - elseif (.not. newthermo) then - til = cpi8 * thil * exner - if (t1stguess > ttripoli8) then - thil2temp8 = 5.d-1 * (til + sqrt(til * ( til & - + cpi48 * (alvl8*rliq + alvi8*rice)))) - else - thil2temp8 = til * ( 1.d0 + (alvl8*rliq+alvi8*rice) * htripolii8) - end if - return - end if + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: dryhcap ! Heat cap. of "dry" part [J/m²/K] or [J/m³/K] + real(kind=8), intent(in) :: wmass ! Mass [ kg/m²] or [ kg/m³] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: fliq ! Liquid fraction (0-1) [ ---] !------------------------------------------------------------------------------------! - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,a,1x,f11.4,2(1x,a,1x,es12.5))') & - ! 'itn=',itn,'bisection=',.false.,'tempz=',tempz-t00 & - ! ,'fun=',fun,'deriv=',deriv - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - converged = abs(tempa-tempz) < toler8 * tempz - !----- Converged, happy with that, return the average b/w the 2 previous guesses -! - if (fun == 0.d0) then - thil2temp8 = tempz - converged = .true. - return - elseif(converged) then - thil2temp8 = 5.d-1 * (tempa+tempz) - return - end if - end do newloop - !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! Internal energy is given by the sum of internal energies of dry part, plus the ! + ! contribution of ice and liquid phases. ! + !------------------------------------------------------------------------------------! + cmtl2uext8 = dryhcap * temp + wmass * ( (1.d0 - fliq) * cice8 * temp & + + fliq * cliq8 * (temp - tsupercool_liq8) ) !------------------------------------------------------------------------------------! - if (funa * fun < 0.d0) then - funz = fun - zside = .true. - else - if (abs(fun-funa) < toler8 * tempa) then - delta = 1.d2 * toler8 * tempa - else - delta = max(abs(funa * (tempz-tempa)/(fun-funa)), 1.d2 * toler8 * tempa) - end if - tempz = tempa + delta - zside = .false. - zgssloop: do itb=1,maxfpo - tempz = tempa + dble((-1)**itb * (itb+3)/2) * delta - funz = theta_iceliq8(exner,tempz,rliq,rice) - thil - zside = funa * funz < 0.d0 - if (zside) exit zgssloop - end do zgssloop - if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'thil =',thil ,'t1st=',t1stguess - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'exner=',exner,'pres=',pres - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'rliq =',rliq ,'rice=',rice - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempa=',tempa,'funa=',funa - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempz=',tempz,'funz=',funz - write (unit=*,fmt='(1(a,1x,es14.7,1x))') 'delta=',delta - call fatal_error('Failed finding the second guess for regula falsi' & - ,'thil2temp8','therm_lib8.f90') - end if - end if + return + end function cmtl2uext8 + !=======================================================================================! + !=======================================================================================! - bisloop: do itb=itn,maxfpo - thil2temp8 = (funz*tempa-funa*tempz)/(funz-funa) - !---------------------------------------------------------------------------------! - ! Now that we updated the guess, check whether they are really close. If so, ! - ! it converged, I can use this as my guess. ! - !---------------------------------------------------------------------------------! - converged = abs(thil2temp8-tempa) < toler8 * thil2temp8 - if (converged) exit bisloop - !------ Finding the new function -------------------------------------------------! - fun = theta_iceliq8(exner,tempz,rliq,rice) - thil - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,6(1x,a,1x,f11.4))') & - ! 'itn=',itb,'bisection=',.true. & - ! ,'temp=',thil2temp-t00,'tempa=',tempa-t00,'tempz=',tempz-t00 & - ! ,'fun=',fun,'funa=',funa,'funz=',funz - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !------ Defining my new interval based on the intermediate value theorem. --------! - if (fun*funa < 0.d0 ) then - tempz = thil2temp8 - funz = fun - !----- If we are updating zside again, modify aside (Illinois method) ---------! - if (zside) funa=funa * 5.d-1 - !----- We just updated zside, setting zside to true. --------------------------! - zside = .true. - else - tempa = thil2temp8 - funa = fun - !----- If we are updating aside again, modify aside (Illinois method) ---------! - if (.not. zside) funz=funz * 5.d-1 - !----- We just updated aside, setting aside to true. --------------------------! - zside = .false. - end if - end do bisloop - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> ttripoli8) then - dtempdrs8 = - temp * qhydm / (rcon * (hh+qhydm)) - else - dtempdrs8 = - temp * qhydm * htripolii8 / rcon - end if + ! Copy specific humidity to shv. ! + !------------------------------------------------------------------------------------! + if (is_shv) then + shv = humi else - til = cpi8 * thil * exner - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli8) then - dtempdrs8 = - til * qhydm /( rcon * cp8 * (2.d0*temp-til)) - else - dtempdrs8 = - til * qhydm * htripolii8 / rcon - end if + shv = humi / (humi + 1.d0) end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Enthalpy is the combination of dry and moist enthalpies, with the latter being ! + ! allowed to change phase. ! + !------------------------------------------------------------------------------------! + hq2temp8 = ( enthalpy + shv * cph2o8 * tsupercool_vap8 ) & + / ( (1.d0 - shv) * cpdry8 + shv * cph2o8 ) + !------------------------------------------------------------------------------------! return - end function dtempdrs8 + end function hq2temp8 !=======================================================================================! !=======================================================================================! @@ -2084,38 +2642,29 @@ end function dtempdrs8 - !=======================================================================================! !=======================================================================================! - ! This fucntion computes the change of ice-liquid potential temperature due to ! - ! sedimentation. The arguments are ice-liquid potential temperature, potential temper- ! - ! ature and temperature in Kelvin, the old and new mixing ratio [kg/kg] and the old and ! - ! new enthalpy [J/kg]. ! + ! This function finds the latent heat of vaporisation for a given temperature. If ! + ! we use the definition of latent heat (difference in enthalpy between liquid and ! + ! vapour phases), and assume that the specific heats are constants, latent heat becomes ! + ! a linear function of temperature. ! !---------------------------------------------------------------------------------------! - real(kind=8) function dthil_sedimentation8(thil,theta,temp,rold,rnew,qrold,qrnew) - use consts_coms, only: ttripoli8,cp8,alvi8,alvl8 - + real(kind=8) function alvl8(temp) + use consts_coms, only : alvl38 & ! intent(in) + , dcpvl8 & ! intent(in) + , t3ple8 ! ! intent(in) implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: thil ! Ice-liquid potential temperature [ K] - real(kind=8), intent(in) :: theta ! Potential temperature [ K] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rold ! Old hydrometeor mixing ratio [ kg/kg] - real(kind=8), intent(in) :: rnew ! New hydrometeor mixing ratio [ kg/kg] - real(kind=8), intent(in) :: qrold ! Old hydrometeor latent enthalpy [ J/kg] - real(kind=8), intent(in) :: qrnew ! New hydrometeor latent enthalpy [ J/kg] + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: temp !------------------------------------------------------------------------------------! - if (newthermo) then - dthil_sedimentation8 = - thil * (alvi8 * (rnew-rold) - (qrnew-qrold)) & - / (cp8 * max(temp,ttripoli8)) - else - dthil_sedimentation8 = - thil*thil * (alvi8*(rnew-rold) - (qrnew-qrold)) & - / (cp8 * max(temp,ttripoli8) * theta) - end if + + !----- Linear function, using latent heat at the triple point as reference. ---------! + alvl8 = alvl38 + dcpvl8 * (temp - t3ple8) + !------------------------------------------------------------------------------------! return - end function dthil_sedimentation8 + end function alvl8 !=======================================================================================! !=======================================================================================! @@ -2126,42 +2675,27 @@ end function dthil_sedimentation8 !=======================================================================================! !=======================================================================================! - ! This function computes the ice-vapour equivalent potential temperature from ! - ! theta_iland the total mixing ratio. This is equivalent to the equivalent potential ! - ! temperature considering also the effects of fusion/melting/sublimation. ! - ! In case you want to find thetae (i.e. without ice) simply provide the logical ! - ! useice as .false. . ! + ! This function finds the latent heat of sublimation for a given temperature. If ! + ! we use the definition of latent heat (difference in enthalpy between ice and vapour ! + ! phases), and assume that the specific heats are constants, latent heat becomes a ! + ! linear function of temperature. ! !---------------------------------------------------------------------------------------! - real(kind=8) function thetaeiv8(thil,pres,temp,rvap,rtot,useice) - use consts_coms, only : alvl8,alvi8,cp8,ep8,p008,rocp8,ttripoli8,t3ple8 + real(kind=8) function alvi8(temp) + use consts_coms, only : alvi38 & ! intent(in) + , dcpvi8 & ! intent(in) + , t3ple8 ! ! intent(in) implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: thil ! Ice-liquid water pot. temp. [ K] - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rvap ! Water vapour mixing ratio [ kg/kg] - real(kind=8), intent(in) :: rtot ! Total mixing ratio [ kg/kg] - logical , intent(in), optional :: useice ! Should I use ice? [ T|F] - !----- Local variables for iterative method -----------------------------------------! - real(kind=8) :: tlcl ! Internal LCL temperature [ K] - real(kind=8) :: plcl ! Lifting condensation pressure [ Pa] - real(kind=8) :: dzlcl ! Thickness of layer beneath LCL[ m] + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: temp !------------------------------------------------------------------------------------! - if (present(useice)) then - call lcl_il8(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl,useice) - else - call lcl_il8(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl) - end if + !----- Linear function, using latent heat at the triple point as reference. ---------! + alvi8 = alvi38 + dcpvi8 * (temp - t3ple8) !------------------------------------------------------------------------------------! - ! The definition of the thetae_iv is the thetae_ivs at the LCL. The LCL, in turn ! - ! is the point in which rtot = rvap = rsat, so at the LCL rliq = rice = 0. ! - !------------------------------------------------------------------------------------! - thetaeiv8 = thetaeivs8(thil,tlcl,rtot,0.d0,0.d0) return - end function thetaeiv8 + end function alvi8 !=======================================================================================! !=======================================================================================! @@ -2172,51 +2706,1277 @@ end function thetaeiv8 !=======================================================================================! !=======================================================================================! - ! This function computes the derivative of ice-vapour equivalent potential tempera- ! - ! ture, based on the expression used to compute the ice-vapour equivalent potential ! - ! temperature (function thetaeiv). ! - ! ! - ! IMPORTANT!!! This CANNOT BE USED to compute d(Thetae_ivs)/dT, because here ! - ! we assume that T(LCL) and saturation mixing ratio are known and ! - ! constants, and that the LCL pressure (actually the saturation vapour ! - ! pressure at the LCL) is a function of temperature. In case you want ! - ! d(Thetae_ivs)/dT, use the dthetaeivs_dt function instead. ! + ! This fucntion computes the ice liquid potential temperature given the Exner ! + ! function [J/kg/K], temperature [K], and liquid and ice mixing ratios [kg/kg]. ! !---------------------------------------------------------------------------------------! - real(kind=8) function dthetaeiv_dtlcl8(theiv,tlcl,rtot,eslcl,useice) - use consts_coms, only : rocp8,aklv8,ttripoli8 + real(kind=8) function theta_iceliq8(exner,temp,rliq,rice) + use consts_coms, only : alvl38 & ! intent(in) + , alvi38 & ! intent(in) + , cpdry8 & ! intent(in) + , ttripoli8 & ! intent(in) + , htripoli8 & ! intent(in) + , htripolii8 ! ! intent(in) + implicit none !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: theiv ! Ice-vapour equiv. pot. temp. [ K] - real(kind=8), intent(in) :: tlcl ! LCL temperature [ K] - real(kind=8), intent(in) :: rtot ! Total mixing ratio (rs @ LCL)[ Pa] - real(kind=8), intent(in) :: eslcl ! LCL saturation vapour press. [ Pa] - logical , intent(in), optional :: useice ! Flag for considering ice [ T|F] + real(kind=8), intent(in) :: exner ! Exner function [ J/kg/K] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] + real(kind=8), intent(in) :: rice ! Ice mixing ratio [ kg/kg] !----- Local variables --------------------------------------------------------------! - real(kind=8) :: desdtlcl ! Sat. vapour pres. deriv. [ Pa/K] + real(kind=8) :: hh ! Enthalpy associated with sensible heat [ J/kg] + real(kind=8) :: qq ! Enthalpy associated with latent heat [ J/kg] !------------------------------------------------------------------------------------! + !----- Find the sensible heat enthalpy (assuming dry air). --------------------------! + hh = cpdry8 * temp + !------------------------------------------------------------------------------------! - !----- Finding the derivative of rs with temperature --------------------------------! - if (present(useice)) then - desdtlcl = eslifp8(tlcl,useice) + + !------------------------------------------------------------------------------------! + ! Find the latent heat enthalpy. If using the old thermodynamics, we use the ! + ! latent heat at T = T3ple, otherwise we use the temperature-dependent one. ! + !------------------------------------------------------------------------------------! + if (newthermo) then + qq = alvl8(temp) * rliq + alvi8(temp) * rice else - desdtlcl = eslifp8(tlcl) + qq = alvl38 * rliq + alvi38 * rice + end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Solve the thermodynamics. For the new thermodynamics we don't approximate ! + ! the exponential to a linear function, nor do we impose temperature above the thre- ! + ! shold from Tripoli and Cotton (1981). ! + !------------------------------------------------------------------------------------! + if (newthermo) then + !----- Decide how to compute, based on temperature. ------------------------------! + theta_iceliq8 = hh * exp(-qq / hh) / exner + !---------------------------------------------------------------------------------! + else + !----- Decide how to compute, based on temperature. ------------------------------! + if (temp > ttripoli8) then + theta_iceliq8 = hh * hh / (exner * ( hh + qq)) + else + theta_iceliq8 = hh * htripoli8 / (exner * ( htripoli8 + qq)) + end if + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + return + end function theta_iceliq8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the liquid potential temperature derivative with respect ! + ! to temperature, useful in iterative methods. ! + !---------------------------------------------------------------------------------------! + real(kind=8) function dthetail_dt8(condconst,thil,exner,pres,temp,rliq,ricein) + use consts_coms, only : alvl38 & ! intent(in) + , alvi38 & ! intent(in) + , dcpvi8 & ! intent(in) + , dcpvl8 & ! intent(in) + , cpdry8 & ! intent(in) + , ttripoli8 & ! intent(in) + , htripoli8 & ! intent(in) + , htripolii8 & ! intent(in) + , t3ple8 ! ! intent(in) + + implicit none + !----- Arguments --------------------------------------------------------------------! + logical , intent(in) :: condconst ! Condensation is constant? [ T|F] + real(kind=8), intent(in) :: thil ! Ice liquid pot. temp. [ K] + real(kind=8), intent(in) :: exner ! Exner function [J/kg/K] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] + real(kind=8), intent(in), optional :: ricein ! Ice mixing ratio [ kg/kg] + !----- Local variables --------------------------------------------------------------! + real(kind=8) :: rice ! Ice mixing ratio or 0. [ kg/kg] + real(kind=8) :: ldrst ! L × d(rs)/dT × T [ J/kg] + real(kind=8) :: rdlt ! r × d(L)/dT × T [ J/kg] + real(kind=8) :: hh ! Sensible heat enthalpy [ J/kg] + real(kind=8) :: qq ! Latent heat enthalpy [ J/kg] + logical :: thereisice ! Is ice present [ ---] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Check whether we should consider ice thermodynamics or not. ! + !------------------------------------------------------------------------------------! + thereisice = present(ricein) + if (thereisice) then + rice = ricein + else + rice = 0.d0 + end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Check whether the current state has condensed water. ! + !------------------------------------------------------------------------------------! + if (rliq+rice == 0.d0) then + !----- No condensation, so dthetail_dt is a constant. ----------------------------! + dthetail_dt8 = thil/temp + return + !---------------------------------------------------------------------------------! + else + !---------------------------------------------------------------------------------! + ! Condensation exists. Compute some auxiliary variables. ! + !---------------------------------------------------------------------------------! + + + !---- Sensible heat enthalpy. ----------------------------------------------------! + hh = cpdry8 * temp + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! Find the latent heat enthalpy. If using the old thermodynamics, we use ! + ! the latent heat at T = T3ple, otherwise we use the temperature-dependent one. ! + ! The term r × d(L)/dT × T is computed only when we use the new thermodynamics. ! + !---------------------------------------------------------------------------------! + if (newthermo) then + qq = alvl8(temp) * rliq + alvi8(temp) * rice + rdlt = (dcpvl8 * rliq + dcpvi8 * rice ) * temp + else + qq = alvl38 * rliq + alvi38 * rice + rdlt = 0.d0 + end if + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! This is the term L×[d(rs)/dt]×T. L may be either the vapourisation or ! + ! sublimation latent heat, depending on the temperature and whether we are consi- ! + ! dering ice or not. We still need to check whether latent heat is a function of ! + ! temperature or not. Also, if condensation mixing ratio is constant, then this ! + ! term will be always zero. ! + !---------------------------------------------------------------------------------! + if (condconst) then + ldrst = 0.d0 + elseif (thereisice .and. temp < t3ple8) then + if (newthermo) then + ldrst = alvi38 * rsifp8(pres,temp) * temp + else + ldrst = alvi8(temp) * rsifp8(pres,temp) * temp + end if + else + if (newthermo) then + ldrst = alvl38 * rslfp8(pres,temp) * temp + else + ldrst = alvl8(temp) * rslfp8(pres,temp) * temp + end if + end if + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Find the condensed phase consistent with the thermodynamics used. ! + !------------------------------------------------------------------------------------! + if (newthermo) then + dthetail_dt8 = thil * ( 1.d0 + (ldrst + qq - rdlt ) / hh ) / temp + else + !----- Decide how to compute, based on temperature. ------------------------------! + if (temp > ttripoli8) then + dthetail_dt8 = thil * ( 1.d0 + (ldrst + qq) / (hh+qq) ) / temp + else + dthetail_dt8 = thil * ( 1.d0 + ldrst / (htripoli8 + alvl38 * rliq) ) / temp + end if + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + return + end function dthetail_dt8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes temperature from the ice-liquid water potential temperature ! + ! in Kelvin, Exner function in J/kg/K, and liquid and ice mixing ratios in kg/kg. ! + ! For now t1stguess is used only to decide whether I should use the complete case or ! + ! the 253 K to reduce the error on neglecting the changes on latent heat due to temper- ! + ! ature. ! + !---------------------------------------------------------------------------------------! + real(kind=8) function thil2temp8(thil,exner,pres,rliq,rice,t1stguess) + use consts_coms, only : cpdry8 & ! intent(in) + , cpdryi8 & ! intent(in) + , cpdryi48 & ! intent(in) + , alvl38 & ! intent(in) + , alvi38 & ! intent(in) + , t008 & ! intent(in) + , t3ple8 & ! intent(in) + , ttripoli8 & ! intent(in) + , htripolii8 ! ! intent(in) + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: thil ! Ice-liquid water potential temp. [ K] + real(kind=8), intent(in) :: exner ! Exner function [J/kg/K] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] + real(kind=8), intent(in) :: rice ! Ice mixing ratio [ kg/kg] + real(kind=8), intent(in) :: t1stguess ! 1st. guess for temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: til ! Ice liquid temperature [ K] + real(kind=8) :: deriv ! Function derivative + real(kind=8) :: fun ! Function for which we seek a root. + real(kind=8) :: funa ! Smallest guess function + real(kind=8) :: funz ! Largest guess function + real(kind=8) :: tempa ! Smallest guess (or previous guess in Newton) + real(kind=8) :: tempz ! Largest guess (or new guess in Newton) + real(kind=8) :: delta ! Aux. var to compute 2nd guess for bisection + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + logical :: converged ! Convergence flag + logical :: zside ! Flag to check for one-sided approach... + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! First we check for conditions that don't require iterative root-finding. ! + !------------------------------------------------------------------------------------! + if (rliq + rice == 0.d0) then + !----- No condensation. Theta_il is the same as theta. --------------------------! + thil2temp8 = cpdryi8 * thil * exner + return + !---------------------------------------------------------------------------------! + elseif (.not. newthermo) then + !---------------------------------------------------------------------------------! + ! There is condensation but we are using the old thermodynamics, which can be ! + ! solved analytically. ! + !---------------------------------------------------------------------------------! + til = cpdryi8 * thil * exner + if (t1stguess > ttripoli8) then + thil2temp8 = 5.d-1 & + * (til + sqrt( til & + * (til + cpdryi48 * (alvl38 * rliq + alvi38 * rice)))) + else + thil2temp8 = til * ( 1.d0 + (alvl38 * rliq + alvi38 * rice) * htripolii8) + end if + return + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,a,1x,f11.4,2(1x,a,1x,es12.5))') & + ! 'itn=',itn,'bisection=',.false.,'tempz=',tempz-t00 & + ! ,'fun=',fun,'deriv=',deriv + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + converged = abs(tempa-tempz) < toler8*tempz + !----- Converged, happy with that, return the average b/w the 2 previous guesses -! + if (fun == 0.d0) then + thil2temp8 = tempz + converged = .true. + return + elseif(converged) then + thil2temp8 = 5.d-1 * (tempa+tempz) + return + end if + end do newloop + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! If we have reached this point then Newton's method failed. Use bisection ! + ! instead. For bisection, We need two guesses whose function evaluations have ! + ! opposite sign. ! + !------------------------------------------------------------------------------------! + if (funa * fun < 0.d0) then + !----- Guesses have opposite sign. -----------------------------------------------! + funz = fun + zside = .true. + else + if (abs(fun-funa) < toler8 * tempa) then + delta = 1.d2 * toler8 * tempa + else + delta = max(abs(funa * (tempz-tempa)/(fun-funa)),1.d2 * toler8 * tempa) + end if + tempz = tempa + delta + zside = .false. + zgssloop: do itb=1,maxfpo + tempz = tempa + dble((-1)**itb * (itb+3)/2) * delta + funz = theta_iceliq8(exner,tempz,rliq,rice) - thil + zside = funa*funz < 0.d0 + if (zside) exit zgssloop + end do zgssloop + if (.not. zside) then + write (unit=*,fmt='(a)') ' No second guess for you...' + write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'thil =',thil ,'t1st=',t1stguess + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'exner=',exner,'pres=',pres + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'rliq =',rliq ,'rice=',rice + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempa=',tempa,'funa=',funa + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempz=',tempz,'funz=',funz + write (unit=*,fmt='(1(a,1x,es14.7,1x))') 'delta=',delta + call fatal_error('Failed finding the second guess for regula falsi' & + ,'thil2temp8','therm_lib8.f90') + end if + end if + + + bisloop: do itb=itn,maxfpo + thil2temp8 = (funz*tempa-funa*tempz)/(funz-funa) + + !---------------------------------------------------------------------------------! + ! Now that we updated the guess, check whether they are really close. If so, ! + ! it converged, I can use this as my guess. ! + !---------------------------------------------------------------------------------! + converged = abs(thil2temp8 - tempa) < toler8 * thil2temp8 + if (converged) exit bisloop + + !------ Finding the new function -------------------------------------------------! + fun = theta_iceliq8(exner,tempz,rliq,rice) - thil + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,6(1x,a,1x,f11.4))') & + ! 'itn=',itb,'bisection=',.true. & + ! ,'temp=',thil2temp-t00,'tempa=',tempa-t00,'tempz=',tempz-t00 & + ! ,'fun=',fun,'funa=',funa,'funz=',funz + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + !------ Defining my new interval based on the intermediate value theorem. --------! + if (fun*funa < 0.d0 ) then + tempz = thil2temp8 + funz = fun + !----- If we are updating zside again, modify aside (Illinois method) ---------! + if (zside) funa = funa * 5.d-1 + !----- We just updated zside, setting zside to true. --------------------------! + zside = .true. + else + tempa = thil2temp8 + funa = fun + !----- If we are updating aside again, modify aside (Illinois method) ---------! + if (.not. zside) funz = funz * 5.d-1 + !----- We just updated aside, setting aside to true. --------------------------! + zside = .false. + end if + end do bisloop + + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> ttripoli8) then + dtempdrs8 = - til * qq / ( rcon * cpdry8 * (2.*temp-til)) + else + dtempdrs8 = - til * qq * htripolii8 / rcon + end if + !------------------------------------------------------------------------------! + end if + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + return + end function dtempdrs8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the ice-vapour equivalent potential temperature from ! + ! theta_iland the total mixing ratio. This is equivalent to the equivalent potential ! + ! temperature considering also the effects of fusion/melting/sublimation. ! + ! In case you want to find thetae (i.e. without ice) simply set the the logical ! + ! useice to .false. . ! + !---------------------------------------------------------------------------------------! + real(kind=8) function thetaeiv8(thil,pres,temp,rvap,rtot,useice) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: thil ! Ice-liquid potential temp. [ K] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: rvap ! Water vapour mixing ratio [ kg/kg] + real(kind=8), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! Should I use ice? [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=8) :: tlcl ! Internal LCL temperature [ K] + real(kind=8) :: plcl ! Lifting condensation pressure [ Pa] + real(kind=8) :: dzlcl ! Thickness of lyr. beneath LCL [ m] + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Find the liquid condensation level (LCL). ! + !------------------------------------------------------------------------------------! + if (present(useice)) then + call lcl_il8(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl,useice) + else + call lcl_il8(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl) + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! The definition of the thetae_iv is the thetae_ivs at the LCL. The LCL, in turn ! + ! is the point in which rtot = rvap = rsat, so at the LCL rliq = rice = 0. ! + !------------------------------------------------------------------------------------! + thetaeiv8 = thetaeivs8(thil,tlcl,rtot,0.d0,0.d0) + !------------------------------------------------------------------------------------! + + return + end function thetaeiv8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the derivative of ice-vapour equivalent potential tempera- ! + ! ture, based on the expression used to compute the ice-vapour equivalent potential ! + ! temperature (function thetaeiv). ! + ! ! + ! IMPORTANT!!! This CANNOT BE USED to compute d(Thetae_ivs)/dT, because here ! + ! we assume that T(LCL) and saturation mixing ratio are known and ! + ! constants, and that the LCL pressure (actually the saturation vapour ! + ! pressure at the LCL) is a function of temperature. In case you want ! + ! d(Thetae_ivs)/dT, use the dthetaeivs_dt function instead. ! + !---------------------------------------------------------------------------------------! + real(kind=8) function dthetaeiv_dtlcl8(theiv,tlcl,rtot,eslcl,useice) + use consts_coms, only : rocp8 & ! intent(in) + , cpdry8 & ! intent(in) + , dcpvl8 ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: theiv ! Ice-vap. equiv. pot. temp. [ K] + real(kind=8), intent(in) :: tlcl ! LCL temperature [ K] + real(kind=8), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + real(kind=8), intent(in) :: eslcl ! LCL sat. vapour pressure [ Pa] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! Flag for considering ice [ T|F] + !----- Local variables --------------------------------------------------------------! + real(kind=8) :: desdtlcl ! Sat. vapour pres. deriv. [ Pa/K] + real(kind=8) :: esterm ! es(TLC) term [ ----] + real(kind=8) :: hhlcl ! Enthalpy -- sensible [ J/kg] + real(kind=8) :: qqlcl ! Enthalpy -- latent [ J/kg] + real(kind=8) :: qptlcl ! Latent deriv. * T_LCL [ J/kg] + !------------------------------------------------------------------------------------! + + + + !----- Find the derivative of rs with temperature. ----------------------------------! + if (present(useice)) then + desdtlcl = eslifp8(tlcl,useice) + else + desdtlcl = eslifp8(tlcl) + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Saturation term. ! + !------------------------------------------------------------------------------------! + esterm = rocp8 * tlcl * desdtlcl / eslcl + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the enthalpy terms. ! + !------------------------------------------------------------------------------------! + hhlcl = cpdry8 * tlcl + qqlcl = alvl8(tlcl) * rtot + qptlcl = dcpvl8 * rtot * tlcl + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Derivative. ! + !------------------------------------------------------------------------------------! + dthetaeiv_dtlcl8 = theiv / tlcl * (1.d0 - esterm - (qqlcl - qptlcl) / hhlcl) + !------------------------------------------------------------------------------------! + + return + end function dthetaeiv_dtlcl8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the saturation ice-vapour equivalent potential temperature ! + ! from theta_il and the total mixing ratio (split into saturated vapour plus liquid and ! + ! ice. This is equivalent to the equivalent potential temperature considering also the ! + ! effects of fusion/melting/sublimation, and it is done separatedly from the regular ! + ! thetae_iv because it doesn't require iterations. ! + ! ! + ! References: ! + ! Tripoli, J. T.; and Cotton, W.R., 1981: The use of ice-liquid water potential tem- ! + ! perature as a thermodynamic variable in deep atmospheric models. Mon. Wea. ! + ! Rev., v. 109, 1094-1102. (TC81) ! + ! ! + ! Some algebra was needed to find this equation, essentially combining (TC81-26) and ! + ! (TC81-27), and the conservation of total water (TC81-16). It assumes that the divi- ! + ! sion between the three phases is already taken care of. ! + !---------------------------------------------------------------------------------------! + real(kind=8) function thetaeivs8(thil,temp,rsat,rliq,rice) + use consts_coms, only : cpdry8 ! ! intent(in) + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: thil ! Theta_il, ice-liquid water pot. temp. [ K] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: rsat ! Saturation water vapour mixing ratio [ kg/kg] + real(kind=8), intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] + real(kind=8), intent(in) :: rice ! Ice mixing ratio [ kg/kg] + !----- Local variables --------------------------------------------------------------! + real(kind=8) :: rtots ! Saturated mixing ratio [ K] + !------------------------------------------------------------------------------------! + + + !------ Find the total saturation mixing ratio. -------------------------------------! + rtots = rsat + rliq + rice + !------------------------------------------------------------------------------------! + + + !------ Find the saturation equivalent potential temperature. -----------------------! + thetaeivs8 = thil * exp ( alvl8(temp) * rtots / (cpdry8 * temp)) + !------------------------------------------------------------------------------------! + + return + end function thetaeivs8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the derivative of saturation ice-vapour equivalent ! + ! potential temperature, based on the expression used to compute the saturation ! + ! ice-vapour equivalent potential temperature (function thetaeivs). ! + ! ! + ! IMPORTANT!!! This CANNOT BE USED to compute d(Thetae_iv)/d(T_LCL), because here ! + ! we assume that temperature and pressure are known and constants, and ! + ! that the mixing ratio is a function of temperature. In case you want ! + ! d(Thetae_iv)/d(T_LCL), use the dthetaeiv_dtlcl function instead. ! + !---------------------------------------------------------------------------------------! + real(kind=8) function dthetaeivs_dt8(theivs,temp,pres,rsat,useice) + use consts_coms, only : cpdry8 & ! intent(in) + , dcpvl8 ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: theivs ! Sat. ice-vap. eq. pot. temp. [ K] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! Flag for considering ice [ T|F] + !----- Local variables --------------------------------------------------------------! + real(kind=8) :: drsdt ! Sat. mixing ratio derivative [kg/kg/K] + real(kind=8) :: hh ! Enthalpy -- sensible [ J/kg] + real(kind=8) :: qqaux ! Enthalpy -- sensible [ J/kg] + !------------------------------------------------------------------------------------! + + + !----- Find the derivative of rs with temperature. ----------------------------------! + if (present(useice)) then + drsdt = rslifp8(pres,temp,useice) + else + drsdt = rslifp8(pres,temp) + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Find the enthalpy terms. ! + !------------------------------------------------------------------------------------! + hh = cpdry8 * temp + qqaux = alvl8(temp) * (drsdt * temp - rsat) + dcpvl8 * rsat * temp + !------------------------------------------------------------------------------------! + + + !----- Find the derivative. Depending on the temperature, use different eqn. -------! + dthetaeivs_dt8 = theivs / temp * ( 1.d0 + qqaux / hh ) + !------------------------------------------------------------------------------------! + + return + end function dthetaeivs_dt8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function finds the ice-liquid potential temperature from the ice-vapour equi- ! + ! valent potential temperature. ! + ! Important remarks: ! + ! 1. If you don't want to use ice thermodynamics, simply force useice to be .false. ! + ! Otherwise, the model will decide based on the LEVEL given by the user from their ! + ! RAMSIN. ! + ! 2. If rtot < rsat, then this will convert theta_e into theta, which can be thought as ! + ! a particular case. ! + !---------------------------------------------------------------------------------------! + real(kind=8) function thetaeiv2thil8(theiv,pres,rtot,useice) + use consts_coms, only : ep8 & ! intent(in) + , cpdry8 & ! intent(in) + , p008 & ! intent(in) + , rocp8 & ! intent(in) + , t3ple8 & ! intent(in) + , t008 ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: theiv ! Ice vap. equiv. pot. temp. [ K] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May I use ice thermodyn. [ T|F] + !----- Local variables for iterative method -----------------------------------------! + real(kind=8) :: pvap ! Sat. vapour pressure + real(kind=8) :: theta ! Potential temperature + real(kind=8) :: deriv ! Function derivative + real(kind=8) :: funnow ! Function for which we seek a root. + real(kind=8) :: funa ! Smallest guess function + real(kind=8) :: funz ! Largest guess function + real(kind=8) :: tlcla ! Smallest guess (Newton: old guess) + real(kind=8) :: tlclz ! Largest guess (Newton: new guess) + real(kind=8) :: tlcl ! What will be the LCL temperature + real(kind=8) :: es00 ! Defined as p00*rt/(epsilon + rt) + real(kind=8) :: delta ! Aux. variable (For 2nd guess). + integer :: itn ! Iteration counters + integer :: itb ! Iteration counters + integer :: ii ! Another counter + logical :: converged ! Convergence handle + logical :: zside ! Side checker for Regula Falsi + logical :: frozen ! Will use ice thermodynamics + !------------------------------------------------------------------------------------! + + + + !----- Fill the flag for ice thermodynamics so it will be present. ------------------! + if (present(useice)) then + frozen = useice + else + frozen = bulk_on + end if + !------------------------------------------------------------------------------------! + + + + !----- Find es00, which is a constant. ----------------------------------------------! + es00 = p008 * rtot / (ep8 + rtot) + !------------------------------------------------------------------------------------! + + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + ! 'NEWTON: it=',itn,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funnow & + ! ,'deriv=',deriv + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + converged = abs(tlcla-tlclz) < toler8 * tlclz + if (funnow == 0.d0) then + tlcl = tlclz + funz = funnow + converged = .true. + exit newloop + elseif (converged) then + tlcl = 5.d-1*(tlcla+tlclz) + funz = funnow + exit newloop + end if + end do newloop + + !------------------------------------------------------------------------------------! + ! If I reached this point then it's because Newton's method failed. Using bisec- ! + ! tion instead. ! + !------------------------------------------------------------------------------------! + if (.not. converged) then + !----- Set funz, and check whether funa and funz already have opposite sign. -----! + funz = funnow + zside=.true. + if (funa*funnow > 0.d0) then + !----- We fix funa, and try a funz that will work as 2nd guess ----------------! + if (abs(funz-funa) < toler8*tlcla) then + delta = 1.d2*toler8*tlcla + else + delta = max(abs(funa*(tlclz-tlcla)/(funz-funa)),1.d2*toler8*tlcla) + end if + tlclz = tlcla + delta + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + ! '2NGGSS: tt=',itb,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funz & + ! ,'delta=',delta + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + zside = funa*funz < 0.d0 + if (zside) exit zgssloop + end do zgssloop + if (.not. zside) then + write (unit=*,fmt='(a)') ' No second guess for you...' + write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theiv =',theiv ,'rtot =',rtot + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'pres =',pres ,'pvap =',pvap + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theta =',theta ,'delta =',delta + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlcla =',tlcla ,'funa =',funa + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlclz =',tlclz ,'funz =',funz + call fatal_error('Failed finding the second guess for regula falsi' & + ,'thetaeiv2thil8','therm_lib8.f90') + end if + end if + !---- Continue iterative method. -------------------------------------------------! + fpoloop: do itb=itn+1,maxfpo + + !----- Update the guess. ------------------------------------------------------! + tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) + + !----- Updating function evaluation -------------------------------------------! + pvap = eslif8(tlcl,frozen) + theta = tlcl * (es00/pvap)**rocp8 + funnow = thetaeivs8(theta,tlcl,rtot,0.d0,0.d0) - theiv + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=36,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + ! 'ANSWER: itb=',itn,'tlcl=',tlcl-t00,'eslcl=',0.01*pvap & + ! ,'thil=',thetaeiv2thil,'funa=',funa,'funz=',funz + !write (unit=36,fmt='(a)') '-------------------------------------------------------' + !write (unit=36,fmt='(a)') ' ' + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + else + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + write (unit=*,fmt='(a)') ' THEIV2THIL8 failed!' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Input: ' + write (unit=*,fmt='(a,1x,f12.5)') ' THEIV [ K]:',theiv + write (unit=*,fmt='(a,1x,f12.5)') ' PRES [ Pa]:',pres * 1.d2 + write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1.d3*rtot + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Output: ' + write (unit=*,fmt='(a,1x,i12)') ' ITERATIONS :',itb + write (unit=*,fmt='(a,1x,f12.5)') ' PVAP [ hPa]:',pvap + write (unit=*,fmt='(a,1x,f12.5)') ' THETA [ K]:',theta + write (unit=*,fmt='(a,1x,f12.5)') ' TLCL [ °C]:',tlcl-t008 + write (unit=*,fmt='(a,1x,f12.5)') ' TLCLA [ °C]:',tlcla-t008 + write (unit=*,fmt='(a,1x,f12.5)') ' TLCLZ [ °C]:',tlclz-t008 + write (unit=*,fmt='(a,1x,es12.5)') ' FUNA [ K]:',funa + write (unit=*,fmt='(a,1x,es12.5)') ' FUNZ [ K]:',funz + write (unit=*,fmt='(a,1x,es12.5)') ' DERIV [ ---]:',deriv + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_A [ ---]:',abs(tlcl-tlcla)/tlcl + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_Z [ ---]:',abs(tlcl-tlclz)/tlcl + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + + call fatal_error('TLCL didn''t converge, qgave up!' & + ,'thetaeiv2thil8','therm_lib8.f90') + end if + + return + end function thetaeiv2thil8 + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This subroutine converts saturated ice-vapour equivalent potential temperature ! + ! into temperature, given pressure in Pa, and theta_es in Kelvin. It also returns the ! + ! potential temperature in Kelvin, and saturation vapour mixing ratio in kg/kg. As ! + ! usual, we seek T using Newton's method as a starting point, and if it fails, we fall ! + ! back to the modified regula falsi (Illinois method). ! + ! ! + ! OBS: In case you want to ignore ice, send useice as false. The default is to consider ! + ! when level >= 3 and to ignore otherwise. ! + !---------------------------------------------------------------------------------------! + subroutine thetaeivs2temp8(theivs,pres,theta,temp,rsat,useice) + use consts_coms, only : cpdry8 & ! intent(in) + , ep8 & ! intent(in) + , p008 & ! intent(in) + , rocp8 & ! intent(in) + , t008 ! ! intent(in) + implicit none + !----- Arguments --------------------------------------------------------------------! + real(kind=8), intent(in) :: theivs ! Sat. thetae_iv [ K] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(out) :: theta ! Potential temperature [ K] + real(kind=8), intent(out) :: temp ! Temperature [ K] + real(kind=8), intent(out) :: rsat ! Saturation mixing ratio [ kg/kg] + logical , intent(in) , optional :: useice ! May use ice thermodyn. [ T|F] + !----- Local variables, with other thermodynamic properties -------------------------! + real(kind=8) :: exnernormi ! 1./ (Norm. Exner func.) [ ---] + logical :: frozen ! Will use ice thermodyn. [ T|F] + !----- Local variables for iterative method -----------------------------------------! + real(kind=8) :: deriv ! Function derivative + real(kind=8) :: funnow ! Current function evaluation + real(kind=8) :: funa ! Smallest guess function + real(kind=8) :: funz ! Largest guess function + real(kind=8) :: tempa ! Smallest guess (Newton: previous) + real(kind=8) :: tempz ! Largest guess (Newton: new) + real(kind=8) :: delta ! Aux. variable for 2nd guess. + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + logical :: converged ! Convergence handle + logical :: zside ! Flag for side check. + !------------------------------------------------------------------------------------! + + + !----- Set up the ice check, in case useice is not present. -------------------------! + if (present(useice)) then + frozen = useice + else + frozen = bulk_on + end if + !------------------------------------------------------------------------------------! + + + + !----- Finding the inverse of normalised Exner, which is constant in this routine ---! + exnernormi = (p008 /pres) ** rocp8 + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! The 1st. guess, no idea, guess 0°C. ! + !------------------------------------------------------------------------------------! + tempz = t008 + theta = tempz * exnernormi + rsat = rslif8(pres,tempz,frozen) + funnow = thetaeivs8(theta,tempz,rsat,0.d0,0.d0) + deriv = dthetaeivs_dt8(funnow,tempz,pres,rsat,frozen) + funnow = funnow - theivs + !------------------------------------------------------------------------------------! + + + !----- Copy here just in case Newton is aborted at the 1st guess. -------------------! + tempa = tempz + funa = funnow + !------------------------------------------------------------------------------------! + + converged = .false. + !----- Newton's method loop. --------------------------------------------------------! + newloop: do itn=1,maxfpo/6 + if (abs(deriv) < toler8) exit newloop !----- Too dangerous, skip to bisection ----! + !----- Updating guesses ----------------------------------------------------------! + tempa = tempz + funa = funnow + + tempz = tempa - funnow/deriv + theta = tempz * exnernormi + rsat = rslif8(pres,tempz,frozen) + funnow = thetaeivs8(theta,tempz,rsat,0.d0,0.d0) + deriv = dthetaeivs_dt8(funnow,tempz,pres,rsat,frozen) + funnow = funnow - theivs + + converged = abs(tempa-tempz) < toler8*tempz + if (funnow == 0.d0) then + converged =.true. + temp = tempz + exit newloop + elseif (converged) then + temp = 5.d-1*(tempa+tempz) + exit newloop + end if + end do newloop + + !------------------------------------------------------------------------------------! + ! If we have reached this point then it's because Newton's method failed. Use ! + ! bisection instead. ! + !------------------------------------------------------------------------------------! + if (.not. converged) then + !----- Set funz, and check whether funa and funz already have opposite sign. -----! + funz = funnow + zside = .false. + !---------------------------------------------------------------------------------! + + if (funa*funnow > 0.d0) then + !----- We fix funa, and try a funz that will work as 2nd guess ----------------! + if (abs(funz-funa) < toler8*tempa) then + delta = 1.d2*toler8*tempa + else + delta = max(abs(funa*(tempz-tempa)/(funz-funa)),1.d2*toler8*tempa) + end if + !------------------------------------------------------------------------------! + + tempz = tempa + delta + zgssloop: do itb=1,maxfpo + !----- So this will be +1 -1 +2 -2 etc. ------------------------------------! + tempz = tempz + dble((-1)**itb * (itb+3)/2) * delta + theta = tempz * exnernormi + rsat = rslif8(pres,tempz,frozen) + funz = thetaeivs8(theta,tempz,rsat,0.d0,0.d0) - theivs + zside = funa*funz < 0.d0 + if (zside) exit zgssloop + end do zgssloop + if (.not. zside) then + call fatal_error('Failed finding the second guess for regula falsi' & + ,'thetaes2temp8','therm_lib8.f90') + end if + end if + !---- Continue iterative method --------------------------------------------------! + fpoloop: do itb=itn+1,maxfpo + if (abs(funz-funa) < toler8*tempa) then + temp = 5.d-1*(tempa+tempz) + else + temp = (funz*tempa-funa*tempz)/(funz-funa) + end if + theta = temp * exnernormi + rsat = rslif8(pres,temp,frozen) + funnow = thetaeivs8(theta,temp,rsat,0.d0,0.d0) - theivs + + !------------------------------------------------------------------------------! + ! Checking for convergence. If it did, return, we found the solution. ! + ! Otherwise, constrain the guesses. ! + !------------------------------------------------------------------------------! + converged = abs(temp-tempa) < toler8*temp + if (converged) then + exit fpoloop + elseif (funnow*funa < 0.d0) then + tempz = temp + funz = funnow + !----- If we are updating zside again, modify aside (Illinois method) ------! + if (zside) funa=funa * 5.d-1 + !----- We just updated zside, setting zside to true. -----------------------! + zside = .true. + else + tempa = temp + funa = funnow + !----- If we are updating aside again, modify zside (Illinois method) ------! + if (.not. zside) funz = funz * 5.d-1 + !----- We just updated aside, setting zside to false -----------------------! + zside = .false. + end if + end do fpoloop end if - - - !----- Finding the derivative. Depending on the temperature, use different eqn. -----! - if (tlcl > ttripoli8) then - dthetaeiv_dtlcl8 = theiv * (1.d0 - rocp8*tlcl*desdtlcl/eslcl - aklv8*rtot/tlcl) & - / tlcl + if (converged) then + !----- Compute theta and rsat with temp just for consistency ---------------------! + theta = temp * exnernormi + rsat = rslif8(pres,temp,frozen) else - dthetaeiv_dtlcl8 = theiv * (1.d0 - rocp8*tlcl*desdtlcl/eslcl ) & - / tlcl + call fatal_error('Temperature didn''t converge, I gave up!' & + ,'thetaes2temp8','therm_lib8.f90') end if return - end function dthetaeiv_dtlcl8 + end subroutine thetaeivs2temp8 !=======================================================================================! !=======================================================================================! @@ -2227,353 +3987,348 @@ end function dthetaeiv_dtlcl8 !=======================================================================================! !=======================================================================================! - ! This function computes the saturation ice-vapour equivalent potential temperature ! - ! from theta_il and the total mixing ratio (split into saturated vapour plus liquid and ! - ! ice. This is equivalent to the equivalent potential temperature considering also the ! - ! effects of fusion/melting/sublimation, and it is done separatedly from the regular ! - ! thetae_iv because it doesn't require iterations. ! + ! This subroutine finds the lifting condensation level given the ice-liquid ! + ! potential temperature in Kelvin, temperature in Kelvin, the pressure in Pascal, and ! + ! the mixing ratio in kg/kg. The output will give the LCL temperature and pressure, and ! + ! the thickness of the layer between the initial point and the LCL. ! ! ! ! References: ! - ! Tripoli, J. T.; and Cotton, W.R., 1981: The use of ice-liquid water potential tem- ! - ! perature as a thermodynamic variable in deep atmospheric models. Mon. Wea. ! + ! Tripoli, J. T.; and Cotton, W.R., 1981: The use of ice-liquid water potential ! + ! temperature as a thermodynamic variable in deep atmospheric models. Mon. Wea. ! ! Rev., v. 109, 1094-1102. (TC81) ! + ! Bolton, D., 1980: The computation of the equivalent potential temperature. Mon. ! + ! Wea. Rev., v. 108, 1046-1053. (BO80) ! ! ! ! Some algebra was needed to find this equation, essentially combining (TC81-26) and ! ! (TC81-27), and the conservation of total water (TC81-16). It assumes that the divi- ! ! sion between the three phases is already taken care of. ! + ! Iterative procedure is needed, and here we iterate looking for T(LCL). Theta_il ! + ! can be rewritten in terms of T(LCL) only, and once we know this thetae_iv becomes ! + ! straightforward. T(LCL) will be found using Newton's method, and in the unlikely ! + ! event it fails,we will fall back to the modified regula falsi (Illinois method). ! + ! ! + ! Important remarks: ! + ! 1. TLCL and PLCL are the actual TLCL and PLCL, so in case condensation exists, they ! + ! will be larger than the actual temperature and pressure (because one would go down ! + ! to reach the equilibrium); ! + ! 2. DZLCL WILL BE SET TO ZERO in case the LCL is beneath the starting level. So in ! + ! case you want to force TLCL <= TEMP and PLCL <= PRES, you can use this variable ! + ! to run the saturation check afterwards. DON'T CHANGE PLCL and TLCL here, they will ! + ! be used for conversions between theta_il and thetae_iv as they are defined here. ! + ! 3. In case you don't want ice, simply pass useice=.false.. Otherwise let the model ! + ! decide by itself based on the LEVEL variable. ! !---------------------------------------------------------------------------------------! - real(kind=8) function thetaeivs8(thil,temp,rsat,rliq,rice) - use consts_coms, only : aklv8, ttripoli8 + subroutine lcl_il8(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl,useice) + use consts_coms, only : cpog8 & ! intent(in) + , ep8 & ! intent(in) + , p008 & ! intent(in) + , rocp8 & ! intent(in) + , t3ple8 & ! intent(in) + , t008 ! ! intent(in) implicit none - !----- Arguments. -------------------------------------------------------------------! - real(kind=8), intent(in) :: thil ! Ice-liquid water potential temp. [ K] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: rsat ! Sat. water vapour mixing ratio [ kg/kg] - real(kind=8), intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] - real(kind=8), intent(in) :: rice ! Ice mixing ratio [ kg/kg] + !----- Required arguments. ----------------------------------------------------------! + real(kind=8), intent(in) :: thil ! Ice liquid pot. temp. (*)[ K] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: temp ! Temperature [ K] + real(kind=8), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + real(kind=8), intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] + real(kind=8), intent(out) :: tlcl ! LCL temperature [ K] + real(kind=8), intent(out) :: plcl ! LCL pressure [ Pa] + real(kind=8), intent(out) :: dzlcl ! Sub-LCL layer thickness [ m] + !------------------------------------------------------------------------------------! + ! (*) This is the most general variable. Thil is exactly theta for no condensation ! + ! condition, and it is the liquid potential temperature if no ice is present. ! + !------------------------------------------------------------------------------------! + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in) , optional :: useice ! May use ice thermodyn.? [ T|F] !----- Local variables. -------------------------------------------------------------! - real(kind=8) :: rtots ! Saturated mixing ratio [ K] + real(kind=8) :: pvap ! Sat. vapour pressure + real(kind=8) :: deriv ! Function derivative + real(kind=8) :: funnow ! Current function evaluation + real(kind=8) :: funa ! Smallest guess function + real(kind=8) :: funz ! Largest guess function + real(kind=8) :: tlcla ! Smallest guess (Newton: previous) + real(kind=8) :: tlclz ! Largest guess (Newton: new) + real(kind=8) :: es00 ! Defined as p00*rt/(epsilon + rt) + real(kind=8) :: delta ! Aux. variable for bisection + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + logical :: converged ! Convergence flag + logical :: zside ! Flag to check sides + logical :: frozen ! Will use ice thermodyn. [ T|F] !------------------------------------------------------------------------------------! - rtots = rsat+rliq+rice - - thetaeivs8 = thil * exp ( aklv8 * rtots / max(temp,ttripoli8)) - - return - end function thetaeivs8 - !=======================================================================================! - !=======================================================================================! - - - - - - !=======================================================================================! - !=======================================================================================! - ! This function computes the derivative of saturation ice-vapour equivalent ! - ! potential temperature, based on the expression used to compute the saturation ! - ! ice-vapour equivalent potential temperature (function thetaeivs). ! - ! ! - ! IMPORTANT!!! This CANNOT BE USED to compute d(Thetae_iv)/d(T_LCL), because here ! - ! we assume that temperature and pressure are known and constants, and ! - ! that the mixing ratio is a function of temperature. In case you want ! - ! d(Thetae_iv)/d(T_LCL), use the dthetaeiv_dtlcl function instead. ! - !---------------------------------------------------------------------------------------! - real(kind=8) function dthetaeivs_dt8(theivs,temp,pres,rsat,useice) - use consts_coms, only : aklv8,alvl8,ttripoli8,htripolii8 - implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: theivs ! Sat. ice-vap. eq. pot. temp. [ K] - real(kind=8), intent(in) :: temp ! Temperature [ K] - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] - logical , intent(in), optional :: useice ! Flag for considering ice [ T|F] - !----- Local variables --------------------------------------------------------------! - real(kind=8) :: drsdt ! Saturated mixing ratio deriv.[kg/kg/K] !------------------------------------------------------------------------------------! - - - !----- Finding the derivative of rs with temperature --------------------------------! - if (present(useice)) then - drsdt = rslifp8(pres,temp,useice) - else - drsdt = rslifp8(pres,temp) - end if - - - !----- Finding the derivative. Depending on the temperature, use different eqn. -----! - if (temp > ttripoli8) then - dthetaeivs_dt8 = theivs * (1.d0 + aklv8 * (drsdt*temp-rsat)/temp ) / temp - else - dthetaeivs_dt8 = theivs * (1.d0 + alvl8 * drsdt * temp * htripolii8 ) / temp - end if - - - return - end function dthetaeivs_dt8 - !=======================================================================================! - !=======================================================================================! - - - - - - - !=======================================================================================! - !=======================================================================================! - ! This function finds the ice-liquid potential temperature from the ice-vapour equi- ! - ! valent potential temperature. ! - ! Important remarks: ! - ! 1. If you don't want to use ice thermodynamics, simply force useice to be .false. ! - ! Otherwise, the model will decide based on the LEVEL given by the user from their ! - ! RAMSIN. ! - ! 2. If rtot < rsat, then this will convert theta_e into theta, which can be thought as ! - ! a particular case. ! - !---------------------------------------------------------------------------------------! - real(kind=8) function thetaeiv2thil8(theiv,pres,rtot,useice) - use consts_coms, only : alvl8,cp8,ep8,p008,rocp8,ttripoli8,t3ple8,t008 - implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: theiv ! Ice vap. equiv. pot. temp. [ K] - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(in) :: rtot ! Total mixing ratio [ kg/kg] - logical , intent(in), optional :: useice ! Flag for ice thermo [ T|F] - !----- Local variables for iterative method -----------------------------------------! - real(kind=8) :: pvap ! Sat. vapour pressure - real(kind=8) :: theta ! Potential temperature - real(kind=8) :: deriv ! Function derivative - real(kind=8) :: funnow ! Function for which we seek a root. - real(kind=8) :: funa ! Smallest guess function - real(kind=8) :: funz ! Largest guess function - real(kind=8) :: tlcla ! Smallest guess (or old guess) - real(kind=8) :: tlclz ! Largest guess (or new guess) - real(kind=8) :: tlcl ! What will be the LCL temperature - real(kind=8) :: es00 ! Defined as p00*rt/(epsilon + rt) - real(kind=8) :: delta ! Aux. variable (For 2nd guess). - integer :: itn,itb ! Iteration counters - integer :: ii ! Another counter - logical :: converged ! Convergence handle - logical :: zside ! Aux. flag - sides for Regula Falsi - logical :: brrr_cold ! Flag - considering ice thermo. + ! Check whether ice thermodynamics is the way to go. ! !------------------------------------------------------------------------------------! - - !----- Filling the flag for ice thermo that will be always present ------------------! if (present(useice)) then - brrr_cold = useice - else - brrr_cold = bulk_on + frozen = useice + else + frozen = bulk_on end if - - !----- Finding es00, which is a constant --------------------------------------------! - es00 = p008 * rtot / (ep8 + rtot) - + !------------------------------------------------------------------------------------! !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & ! 'NEWTON: it=',itn,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funnow & ! ,'deriv=',deriv !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - converged = abs(tlcla-tlclz) < toler8 * tlclz - if (funnow == 0.d0) then - tlcl = tlclz + !---------------------------------------------------------------------------------! + ! Check for convergence. ! + !---------------------------------------------------------------------------------! + converged = abs(tlcla-tlclz) < toler8*tlclz + if (converged) then + !----- Guesses are almost identical, average them. ----------------------------! + tlcl = 5.d-1*(tlcla+tlclz) funz = funnow - converged = .true. exit newloop - elseif (converged) then - tlcl = 5.d-1 *(tlcla+tlclz) + !------------------------------------------------------------------------------! + elseif (funnow == 0.d0) then + !----- We've hit the answer by luck, copy the answer. -------------------------! + tlcl = tlclz funz = funnow + converged = .true. exit newloop + !------------------------------------------------------------------------------! end if end do newloop + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! Check whether Newton's method has converged. ! !------------------------------------------------------------------------------------! if (.not. converged) then - !----- Set funz, and check whether funa and funz already have opposite sign. -----! - funz = funnow - zside = .true. - if (funa*funnow > 0.d0) then + !---------------------------------------------------------------------------------! + ! Newton's method has failed. We use regula falsi instead. First, we must ! + ! find two guesses whose function evaluations have opposite signs. ! + !---------------------------------------------------------------------------------! + if (funa*funnow < 0.d0 ) then + !----- We already have two good guesses. --------------------------------------! + funz = funnow + zside = .true. + !------------------------------------------------------------------------------! + else + !------------------------------------------------------------------------------! + ! We need to find another guess with opposite sign. ! + !------------------------------------------------------------------------------! + !----- We fix funa, and try a funz that will work as 2nd guess ----------------! - if (abs(funz-funa) < toler8 * tlcla) then - delta = 1.d2 * toler8 * tlcla + if (abs(funnow-funa) < toler8*tlcla) then + delta = 1.d2*toler8*tlcla else - delta = max(abs(funa*(tlclz-tlcla)/(funz-funa)),1.d2 * toler8 * tlcla) + delta = max(abs(funa*(tlclz-tlcla)/(funnow-funa)),1.d2*toler8*tlcla) end if tlclz = tlcla + delta + !------------------------------------------------------------------------------! !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & ! '2NGGSS: tt=',itb,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funz & ! ,'delta=',delta !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - zside = funa*funz < 0.d0 if (zside) exit zgssloop end do zgssloop if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theiv =',theiv ,'rtot =',rtot - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'pres =',pres ,'pvap =',pvap - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theta =',theta ,'delta =',delta - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlcla =',tlcla ,'funa =',funa - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlclz =',tlclz ,'funz =',funz + write (unit=*,fmt='(a)') ' ====== No second guess for you... ======' + write (unit=*,fmt='(a)') ' + INPUT variables: ' + write (unit=*,fmt='(a,1x,es14.7)') 'THIL =',thil + write (unit=*,fmt='(a,1x,es14.7)') 'TEMP =',temp + write (unit=*,fmt='(a,1x,es14.7)') 'PRES =',pres + write (unit=*,fmt='(a,1x,es14.7)') 'RTOT =',rtot + write (unit=*,fmt='(a,1x,es14.7)') 'RVAP =',rvap + write (unit=*,fmt='(a)') ' ============ Failed guess... ===========' + write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLA =',tlcla,'FUNA =',funa + write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLZ =',tlclz,'FUNC =',funz + write (unit=*,fmt='(2(a,1x,es14.7))') 'DELTA =',delta,'FUNN =',funnow call fatal_error('Failed finding the second guess for regula falsi' & - ,'thetaeiv2thil8','therm_lib8.f90') + ,'lcl_il8','therm_lib8.f90') end if end if - !---- Continue iterative method --------------------------------------------------! - fpoloop: do itb=itn+1,maxfpo + !---------------------------------------------------------------------------------! - !----- Updating the guess -----------------------------------------------------! - tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) - !----- Updating function evaluation -------------------------------------------! - pvap = eslif8(tlcl,brrr_cold) - theta = tlcl * (es00/pvap)**rocp8 - funnow = thetaeivs8(theta,tlcl,rtot,0.d0,0.d0) - theiv + !---------------------------------------------------------------------------------! + ! We have the guesses, solve the regula falsi method. ! + !---------------------------------------------------------------------------------! + fpoloop: do itb=itn+1,maxfpo + !----- Update guess and function evaluation. ----------------------------------! + tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) + pvap = eslif8(tlcl,frozen) + funnow = tlcl * (es00/pvap)**rocp8 - thil + !------------------------------------------------------------------------------! !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=36,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + !write (unit=21,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),3(a,1x,es11.4,1x))') & ! 'ANSWER: itb=',itn,'tlcl=',tlcl-t00,'eslcl=',0.01*pvap & - ! ,'thil=',thetaeiv2thil,'funa=',funa,'funz=',funz - !write (unit=36,fmt='(a)') '-------------------------------------------------------' - !write (unit=36,fmt='(a)') ' ' + ! ,'dzlcl=',dzlcl,'plcl=',plcl*0.01,'funa=',funa,'funz=',funz + !write (unit=21,fmt='(a)') '-------------------------------------------------------' + !write (unit=21,fmt='(a)') ' ' !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! else - write (unit=*,fmt='(60a1)') ('-',ii=1,60) - write (unit=*,fmt='(a)') ' THEIV2THIL8 failed!' - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' -> Input: ' - write (unit=*,fmt='(a,1x,f12.5)') ' THEIV [ K]:',theiv - write (unit=*,fmt='(a,1x,f12.5)') ' PRES [ Pa]:',pres * 1.d2 - write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1.d3*rtot - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' -> Output: ' - write (unit=*,fmt='(a,1x,i12)') ' ITERATIONS :',itb - write (unit=*,fmt='(a,1x,f12.5)') ' PVAP [ hPa]:',pvap - write (unit=*,fmt='(a,1x,f12.5)') ' THETA [ K]:',theta - write (unit=*,fmt='(a,1x,f12.5)') ' TLCL [ °C]:',tlcl-t008 - write (unit=*,fmt='(a,1x,f12.5)') ' TLCLA [ °C]:',tlcla-t008 - write (unit=*,fmt='(a,1x,f12.5)') ' TLCLZ [ °C]:',tlclz-t008 - write (unit=*,fmt='(a,1x,es12.5)') ' FUNA [ K]:',funa - write (unit=*,fmt='(a,1x,es12.5)') ' FUNZ [ K]:',funz - write (unit=*,fmt='(a,1x,es12.5)') ' DERIV [ ---]:',deriv - write (unit=*,fmt='(a,1x,es12.5)') ' ERR_A [ ---]:',abs(tlcl-tlcla)/tlcl - write (unit=*,fmt='(a,1x,es12.5)') ' ERR_Z [ ---]:',abs(tlcl-tlclz)/tlcl - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(60a1)') ('-',ii=1,60) - - call fatal_error('TLCL didn''t converge, gave up!','thetaeiv2thil8' & - ,'therm_lib8.f90') + write (unit=*,fmt='(a)') '-------------------------------------------------------' + write (unit=*,fmt='(a)') ' LCL Temperature didn''t converge!!!' + write (unit=*,fmt='(a,1x,i5,1x,a)') ' I gave up, after',maxfpo,'iterations...' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input values.' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a,1x,f12.4)' ) 'theta_il [ K] =',thil + write (unit=*,fmt='(a,1x,f12.4)' ) 'Pressure [ hPa] =',1.d-2*pres + write (unit=*,fmt='(a,1x,f12.4)' ) 'Temperature [ °C] =',temp-t008 + write (unit=*,fmt='(a,1x,f12.4)' ) 'rtot [ g/kg] =',1.d3*rtot + write (unit=*,fmt='(a,1x,f12.4)' ) 'rvap [ g/kg] =',1.d3*rvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Last iteration outcome.' + write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcla [ °C] =',tlcla-t008 + write (unit=*,fmt='(a,1x,f12.4)' ) 'tlclz [ °C] =',tlclz-t008 + write (unit=*,fmt='(a,1x,f12.4)' ) 'fun [ K] =',funnow + write (unit=*,fmt='(a,1x,f12.4)' ) 'funa [ K] =',funa + write (unit=*,fmt='(a,1x,f12.4)' ) 'funz [ K] =',funz + write (unit=*,fmt='(a,1x,f12.4)' ) 'deriv [ ----] =',deriv + write (unit=*,fmt='(a,1x,es12.4)') 'toler8 [ ----] =',toler8 + write (unit=*,fmt='(a,1x,es12.4)') 'error [ ----] =' & + ,abs(tlclz-tlcla)/tlclz + write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcl [ °C] =',tlcl + call fatal_error('TLCL didn''t converge, gave up!','lcl_il8','therm_lib8.f90') end if - return - end function thetaeiv2thil8 + end subroutine lcl_il8 !=======================================================================================! !=======================================================================================! @@ -2584,167 +4339,409 @@ end function thetaeiv2thil8 !=======================================================================================! !=======================================================================================! - ! This subroutine converts saturated ice-vapour equivalent potential temperature ! - ! into temperature, given pressure in Pa, and theta_es in Kelvin. It also returns the ! - ! potential temperature in Kelvin, and saturation vapour mixing ratio in kg/kg. As ! - ! usual, we seek T using Newton's method as a starting point, and if it fails, we fall ! - ! back to the modified regula falsi (Illinois method). ! - ! ! - ! OBS: In case you want to ignore ice, send useice as false. The default is to consider ! - ! when level >= 3 and to ignore otherwise. ! + ! This subroutine computes a consistent set of temperature and condensated phases ! + ! mixing ratio for a given theta_il, Exner function, and total mixing ratio. This is ! + ! very similar to the function thil2temp, except that now we don't know rliq and rice, ! + ! and for this reason they also become functions of temperature, since they are defined ! + ! as rtot-rsat(T,p), remembering that rtot and p are known. If the air is not ! + ! saturated, we rather use the fact that theta_il = theta and skip the hassle. ! + ! Otherwise, we use iterative methods. We will always try Newton's method, since it ! + ! converges fast. The caveat is that Newton may fail, and it actually does fail very ! + ! close to the triple point, because the saturation vapour pressure function has a ! + ! "kink" at the triple point (continuous, but not differentiable). If that's the case, ! + ! then we fall back to a modified regula falsi (Illinois) method, which is a mix of ! + ! secant and bisection and will converge. ! !---------------------------------------------------------------------------------------! - subroutine thetaeivs2temp8(theivs,pres,theta,temp,rsat,useice) - use consts_coms, only : alvl8,cp8,ep8,p008,rocp8,ttripoli8,t008 + subroutine thil2tqall8(thil,exner,pres,rtot,rliq,rice,temp,rvap,rsat) + use consts_coms, only : cpdry8 & ! intent(in) + , cpdryi8 & ! intent(in) + , t008 & ! intent(in) + , toodry8 & ! intent(in) + , t3ple8 & ! intent(in) + , ttripoli8 ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: theivs ! Sat. thetae_iv [ K] - real(kind=8), intent(in) :: pres ! Pressure [ Pa] - real(kind=8), intent(out) :: theta ! Potential temperature [ K] - real(kind=8), intent(out) :: temp ! Temperature [ K] - real(kind=8), intent(out) :: rsat ! Saturation mixing ratio [ kg/kg] - logical , intent(in) , optional :: useice ! Flag for ice thermo [ T|F] - !----- Local variables, with other thermodynamic properties -------------------------! - real(kind=8) :: exnernormi ! 1./ (Norm. Exner fctn) [ ---] - logical :: brrr_cold ! Flag for ice thermo [ T|F] - !----- Local variables for iterative method -----------------------------------------! - real(kind=8) :: deriv ! Function derivative - real(kind=8) :: funnow ! Function for which we seek a root. - real(kind=8) :: funa ! Smallest guess function - real(kind=8) :: funz ! Largest guess function - real(kind=8) :: tempa ! Smallest guess (or previous) - real(kind=8) :: tempz ! Largest guess (or new) - real(kind=8) :: delta ! Aux. var. for 2nd guess finding. - integer :: itn,itb ! Iteration counters - logical :: converged ! Convergence handle - logical :: zside ! Check sides (Regula Falsi) + !----- Arguments. -------------------------------------------------------------------! + real(kind=8), intent(in) :: thil ! Ice-liquid water potential temp. [ K] + real(kind=8), intent(in) :: exner ! Exner function [J/kg/K] + real(kind=8), intent(in) :: pres ! Pressure [ Pa] + real(kind=8), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + real(kind=8), intent(out) :: rliq ! Liquid water mixing ratio [ kg/kg] + real(kind=8), intent(out) :: rice ! Ice mixing ratio [ kg/kg] + real(kind=8), intent(inout) :: temp ! Temperature [ K] + real(kind=8), intent(out) :: rvap ! Water vapour mixing ratio [ kg/kg] + real(kind=8), intent(out) :: rsat ! Sat. water vapour mixing ratio [ kg/kg] + !----- Local variables --------------------------------------------------------------! + real(kind=8) :: tempa ! Lower bound for regula falsi iteration + real(kind=8) :: tempz ! Upper bound for regula falsi iteration + real(kind=8) :: t1stguess ! Book keeping temperature 1st guess + real(kind=8) :: fun1st ! Book keeping 1st guess function + real(kind=8) :: funa ! Function evaluation at tempa + real(kind=8) :: funz ! Function evaluation at tempz + real(kind=8) :: funnow ! Function at this iteration. + real(kind=8) :: delta ! Aux. var in case we need regula falsi. + real(kind=8) :: deriv ! Derivative of this function. + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + integer :: ii ! Iteration counter + logical :: converged ! Convergence handle + logical :: zside ! Aux. Flag, for two purposes: + ! 1. Found a 2nd guess for regula falsi. + ! 2. I retained the "zside" (T/F) !------------------------------------------------------------------------------------! - - !----- Setting up the ice check, in case useice is not present. ---------------------! - if (present(useice)) then - brrr_cold = useice - else - brrr_cold = bulk_on + + t1stguess = temp + + !------------------------------------------------------------------------------------! + ! First check: try to find temperature assuming sub-saturation and check if ! + ! this is the case. If it is, then there is no need to go through the iterative ! + ! loop. ! + !------------------------------------------------------------------------------------! + tempz = cpdryi8 * thil * exner + rsat = max(toodry8,rslif8(pres,tempz)) + if (tempz >= t3ple8) then + rliq = max(0.d0,rtot-rsat) + rice = 0.d0 + else + rice = max(0.d0,rtot-rsat) + rliq = 0.d0 end if - - !----- Finding the inverse of normalised Exner, which is constant in this routine ---! - exnernormi = (p008 /pres) ** rocp8 + rvap = rtot-rliq-rice + !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! - ! The 1st. guess, no idea, guess 0°C. ! + ! If rtot < rsat, this is not saturated, we can leave the subroutine and bypass ! + ! the iterative part. ! !------------------------------------------------------------------------------------! - tempz = t008 - theta = tempz * exnernormi - rsat = rslif8(pres,tempz,brrr_cold) - funnow = thetaeivs8(theta,tempz,rsat,0.d0,0.d0) - deriv = dthetaeivs_dt8(funnow,tempz,pres,rsat,brrr_cold) - funnow = funnow - theivs + if (rtot < rsat) then + temp = tempz + return + end if - !----- Saving here just in case Newton is aborted at the 1st guess ------------------! - tempa = tempz - funa = funnow + !------------------------------------------------------------------------------------! + ! If not, then use the temperature the user gave as first guess and solve ! + ! iteratively. We use the user instead of what we just found because if the air is ! + ! saturated, then this can be too far off which may be bad for Newton's method. ! + !------------------------------------------------------------------------------------! + tempz = temp + rsat = max(toodry8,rslif8(pres,tempz)) + if (tempz >= t3ple8) then + rliq = max(0.d0,rtot-rsat) + rice = 0.d0 + else + rice = max(0.d0,rtot-rsat) + rliq = 0.d0 + end if + rvap = rtot-rliq-rice - converged = .false. - !----- Looping ----------------------------------------------------------------------! + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>= t3ple8) then + rliq = max(0.d0,rtot-rsat) + rice = 0.d0 + else + rice = max(0.d0,rtot-rsat) + rliq = 0.d0 + end if + rvap = rtot-rliq-rice + + !----- Updating the function -----------------------------------------------------! + funnow = theta_iceliq8(exner,tempz,rliq,rice) + !----- Updating the derivative. --------------------------------------------------! + deriv = dthetail_dt8(.false.,funnow,exner,pres,tempz,rliq,rice) + funnow = funnow - thil + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=46,fmt='(a,1x,i5,1x,6(a,1x,f11.4,1x),a,1x,es11.4,1x)') & + ! 'NEWTON: it=',itn,'temp=',tempz-t00,'rsat=',1000.*rsat,'rliq=',1000.*rliq & + ! ,'rice=',1000.*rice,'rvap=',1000.*rvap,'fun=',funnow,'deriv=',deriv + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + converged = abs(tempa-tempz) < toler8*tempz + !---------------------------------------------------------------------------------! + ! Convergence. The temperature will be the mid-point between tempa and tempz. ! + ! Fix the mixing ratios and return. But first check for converged due to luck. If ! + ! the guess gives a root, then that's it. It looks unlikely, but it actually ! + ! happens sometimes and if not checked it becomes a singularity. ! + !---------------------------------------------------------------------------------! if (funnow == 0.d0) then - converged =.true. temp = tempz + converged = .true. exit newloop elseif (converged) then temp = 5.d-1 * (tempa+tempz) + rsat = max(toodry8,rslif8(pres,temp)) + if (temp >= t3ple8) then + rliq = max(0.d0,rtot-rsat) + rice = 0.d0 + else + rice = max(0.d0,rtot-rsat) + rliq = 0.d0 + end if + rvap = rtot-rliq-rice exit newloop end if - end do newloop + end do newloop !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! - !------------------------------------------------------------------------------------! + + !----- For debugging only -----------------------------------------------------------! + itb = itn+1 + if (.not. converged) then - !----- Set funz, and check whether funa and funz already have opposite sign. -----! - funz = funnow - zside = .false. - if (funa*funnow > 0.d0) then - !----- We fix funa, and try a funz that will work as 2nd guess ----------------! - if (abs(funz-funa) < toler8 * tempa) then + !---------------------------------------------------------------------------------! + ! If I reach this point, then it means that Newton's method failed finding the ! + ! equilibrium, so we are going to use the regula falsi instead. If Newton's ! + ! method didn't converge, we use tempa as one guess and now we seek a tempz with ! + ! opposite sign. ! + !---------------------------------------------------------------------------------! + !----- Check funa and funnow have opposite signs. If so, we are ready to go ------! + if (funa*funnow < 0.d0) then + funz = funnow + zside = .true. + !----- Otherwise, checking whether the 1st guess had opposite sign. --------------! + elseif (funa*fun1st < 0.d0 ) then + funz = fun1st + zside = .true. + !---------------------------------------------------------------------------------! + ! Looking for a guess. Extrapolate funa linearly, trying to get the -funa. We ! + ! don't need it to be funa, just with the opposite sign. If that's not enough, ! + ! we keep going further... Force the guesses to be at least 1K apart ! + !---------------------------------------------------------------------------------! + else + if (abs(funnow-funa) < 1.d2 * toler8 * tempa) then delta = 1.d2 * toler8 * tempa else - delta = max(abs(funa*(tempz-tempa)/(funz-funa)), 1.d2 * toler8 * tempa) + delta = max(abs(funa)*abs((tempz-tempa)/(funnow-funa)),1.d2*toler8*tempa) end if tempz = tempa + delta + funz = funa + !----- Just to enter at least once. The 1st time tempz=tempa-2*delta ----------! + zside = .false. zgssloop: do itb=1,maxfpo - !----- So this will be +1 -1 +2 -2 etc. ------------------------------------! - tempz = tempz + dble((-1)**itb * (itb+3)/2) * delta - theta = tempz * exnernormi - rsat = rslif8(pres,tempz,brrr_cold) - funz = thetaeivs8(theta,tempz,rsat,0.d0,0.d0) - theivs - zside = funa*funz < 0.d0 - if (zside) exit zgssloop + tempz = tempa + dble((-1)**itb * (itb+3)/2) * delta + rsat = max(toodry8,rslif8(pres,tempz)) + if (tempz >= t3ple8) then + rliq = max(0.d0,rtot-rsat) + rice = 0.d0 + else + rice = max(0.d0,rtot-rsat) + rliq = 0.d0 + end if + rvap = rtot-rliq-rice + funz = theta_iceliq8(exner,tempz,rliq,rice) - thil + zside = funa*funz < 0.d0 + if (zside) exit zgssloop end do zgssloop - if (.not. zside) & + if (.not. zside) then + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + write (unit=*,fmt='(a)') ' THIL2TQALL: NO SECOND GUESS FOR YOU!' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Input: ' + write (unit=*,fmt='(a,1x,f12.5)') ' THETA_IL [ K]:',thil + write (unit=*,fmt='(a,1x,f12.5)') ' PRESS [ hPa]:',1.d-2*pres + write (unit=*,fmt='(a,1x,f12.5)') ' EXNER [J/kg/K]:',exner + write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1.d3*rtot + write (unit=*,fmt='(a,1x,f12.5)') ' T1ST [ degC]:',t1stguess-t008 + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPA [ degC]:',tempa-t008 + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPZ [ degC]:',tempz-t008 + write (unit=*,fmt='(a,1x,f12.5)') ' FUNNOW [ K]:',funnow + write (unit=*,fmt='(a,1x,f12.5)') ' FUNA [ K]:',funa + write (unit=*,fmt='(a,1x,f12.5)') ' FUNZ [ K]:',funz + write (unit=*,fmt='(a,1x,f12.5)') ' DELTA [ K]:',delta + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + call fatal_error('Failed finding the second guess for regula falsi' & - ,'thetaes2temp','therm_lib.f90') + ,'thil2tqall8','therm_lib8.f90') + end if end if - !---- Continue iterative method --------------------------------------------------! - fpoloop: do itb=itn+1,maxfpo - if (abs(funz-funa) < toler8 * tempa) then - temp = 5.d-1 * (tempa+tempz) + !---------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------! + ! Now we loop until convergence is achieved. One important thing to notice ! + ! is that Newton's method fail only when T is almost T3ple, which means that ice ! + ! and liquid should be present, and we are trying to find the saturation point ! + ! with all ice or all liquid. This will converge but the final answer will ! + ! contain significant error. To reduce it we redistribute the condensates between ! + ! ice and liquid conserving the total condensed mixing ratio. ! + !---------------------------------------------------------------------------------! + fpoloop: do itb=itn,maxfpo + temp = (funz*tempa-funa*tempz)/(funz-funa) + !----- Checking whether this guess will fall outside the range ----------------! + if (abs(temp-tempa) > abs(tempz-tempa) .or. & + abs(temp-tempz) > abs(tempz-tempa)) then + temp = 5.d-1*(tempa+tempz) + end if + !----- Distributing vapour into the three phases ------------------------------! + rsat = max(toodry8,rslif8(pres,temp)) + rvap = min(rtot,rsat) + if (temp >= t3ple8) then + rliq = max(0.d0,rtot-rsat) + rice = 0.d0 else - temp = (funz*tempa-funa*tempz)/(funz-funa) + rliq = 0.d0 + rice = max(0.d0,rtot-rsat) end if - theta = temp * exnernormi - rsat = rslif8(pres,temp,brrr_cold) - funnow = thetaeivs8(theta,temp,rsat,0.d0,0.d0) - theivs + !----- Updating function ------------------------------------------------------! + funnow = theta_iceliq8(exner,temp,rliq,rice) - thil + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> Input: ' + write (unit=*,fmt='(a,1x,f12.5)') ' THETA_IL [ K]:',thil + write (unit=*,fmt='(a,1x,f12.5)') ' EXNER [J/kg/K]:',exner + write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1.d3*rtot + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Output: ' + write (unit=*,fmt='(a,1x,i12)') ' ITERATIONS :',itb + write (unit=*,fmt='(a,1x,f12.5)') ' TEMP [ °C]:',temp-t008 + write (unit=*,fmt='(a,1x,f12.5)') ' RVAP [ g/kg]:',1.d3*rvap + write (unit=*,fmt='(a,1x,f12.5)') ' RLIQ [ g/kg]:',1.d3*rliq + write (unit=*,fmt='(a,1x,f12.5)') ' RICE [ g/kg]:',1.d3*rice + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPA [ °C]:',tempa-t008 + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPZ [ °C]:',tempz-t008 + write (unit=*,fmt='(a,1x,es12.5)') ' FUNA [ K]:',funnow + write (unit=*,fmt='(a,1x,es12.5)') ' FUNZ [ K]:',funnow + write (unit=*,fmt='(a,1x,es12.5)') ' DERIV [ ---]:',deriv + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_A [ ---]:',abs(temp-tempa)/temp + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_Z [ ---]:',abs(temp-tempz)/temp + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + call fatal_error('Failed finding equilibrium, I gave up!','thil2tqall8' & + ,'therm_lib8.f90') end if - + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & - ! 'NEWTON: it=',itn,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funnow & - ! ,'deriv=',deriv - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !----- Go to bisection if the derivative is too flat (too dangerous...) ----------! + if (abs(deriv) < toler8) exit newloop - !------------------------------------------------------------------------------! - ! Convergence may happen when we get close guesses. ! - !------------------------------------------------------------------------------! - converged = abs(tlcla-tlclz) < toler8 * tlclz - if (converged) then - tlcl = 5.d-1*(tlcla+tlclz) - funz = funnow - exit newloop - elseif (funnow == 0.d0) then - tlcl = tlclz - funz = funnow + tempz = tempa - funnow / deriv + + !----- Finding the mixing ratios associated with this guess ----------------------! + rsat = max(toodry8,rslf8(pres,tempz)) + rliq = max(0.d0,rtot-rsat) + rvap = rtot-rliq + + !----- Updating the function -----------------------------------------------------! + funnow = theta_iceliq8(exner,tempz,rliq,0.d0) + !----- Updating the derivative. --------------------------------------------------! + deriv = dthetail_dt8(.false.,funnow,exner,pres,tempz,rliq) + funnow = funnow - thil + + converged = abs(tempa-tempz) < toler8*tempz + !---------------------------------------------------------------------------------! + ! Convergence. The temperature will be the mid-point between tempa and tempz. ! + ! Fix the mixing ratios and return. But first check for converged due to luck. If ! + ! the guess gives a root, then that's it. It looks unlikely, but it actually ! + ! happens sometimes and if not checked it becomes a singularity. ! + !---------------------------------------------------------------------------------! + if (funnow == 0.d0) then + temp = tempz converged = .true. exit newloop + elseif (converged) then + temp = 5.d-1 * (tempa+tempz) + rsat = max(toodry8,rslf8(pres,temp)) + rliq = max(0.d0,rtot-rsat) + rvap = rtot-rliq + exit newloop end if + !---------------------------------------------------------------------------------! end do newloop + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! if (.not. converged) then !---------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using re- ! - ! gula falsi instead. First, I need to find two guesses that give me functions ! - ! with opposite signs. If funa and funnow have opposite signs, then we are all ! - ! set. ! + ! If I reach this point, then it means that Newton's method failed finding the ! + ! equilibrium, so we are going to use the regula falsi instead. If Newton's ! + ! method didn't converge, we use tempa as one guess and now we seek a tempz with ! + ! opposite sign. ! !---------------------------------------------------------------------------------! - if (funa*funnow < 0.d0 ) then - funz = funnow + !----- Check funa and funnow have opposite signs. If so, we are ready to go ------! + if (funa*funnow < 0.d0) then + funz = funnow zside = .true. - !----- They have the same sign, seeking the other guess --------------------------! + !---------------------------------------------------------------------------------! + ! Looking for a guess. Extrapolate funa linearly, trying to get the -funa. We ! + ! don't need it to be funa, just with the opposite sign. If that's not enough, ! + ! we keep going further... Force the guesses to be at least 1K apart ! + !---------------------------------------------------------------------------------! else - - !----- We fix funa, and try a funz that will work as 2nd guess ----------------! - if (abs(funnow-funa) < toler8 * tlcla) then - delta = 1.d2 * toler8 * tlcla + if (abs(funnow-funa) < toler8*tempa) then + delta = 1.d2*toler8*tempa else - delta = max(abs(funa*(tlclz-tlcla)/(funnow-funa)),1.d2 * toler8 * tlcla) + delta = max(abs(funa*(tempz-tempa)/(funnow-funa)),1.d2*toler8*tempa) end if - tlclz = tlcla + delta - - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & - ! '2NGGSS: tt=',itb,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funz & - ! ,'delta=',delta - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + tempz = tempz + dble((-1)**itb * (itb+3)/2) * delta + rsat = max(toodry8,rslf8(pres,tempz)) + rliq = max(0.d0,rtot-rsat) + rvap = rtot-rliq + funz = theta_iceliq8(exner,tempz,rliq,0.d0) - thil zside = funa*funz < 0.d0 if (zside) exit zgssloop end do zgssloop - if (.not. zside) then - write (unit=*,fmt='(a)') ' ====== No second guess for you... ======' - write (unit=*,fmt='(a)') ' + INPUT variables: ' - write (unit=*,fmt='(a,1x,es14.7)') 'THIL =',thil - write (unit=*,fmt='(a,1x,es14.7)') 'TEMP =',temp - write (unit=*,fmt='(a,1x,es14.7)') 'PRES =',pres - write (unit=*,fmt='(a,1x,es14.7)') 'RTOT =',rtot - write (unit=*,fmt='(a,1x,es14.7)') 'RVPR =',rvpr - write (unit=*,fmt='(a)') ' ============ Failed guess... ===========' - write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLA =',tlcla,'FUNA =',funa - write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLZ =',tlclz,'FUNC =',funz - write (unit=*,fmt='(2(a,1x,es14.7))') 'DELTA =',delta,'FUNN =',funnow + if (.not. zside) & call fatal_error('Failed finding the second guess for regula falsi' & - ,'lcl_il8','therm_lib8.f90') - end if + ,'thil2tqliq','rthrm.f90') end if - !---- Continue iterative method --------------------------------------------------! - fpoloop: do itb=itn+1,maxfpo - - tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) - - pvap = eslif8(tlcl,brrr_cold) - - funnow = tlcl * (es00/pvap)**rocp8 - thil + !---------------------------------------------------------------------------------! - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=21,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),3(a,1x,es11.4,1x))') & - ! 'ANSWER: itb=',itn,'tlcl=',tlcl-t00,'eslcl=',0.01*pvap & - ! ,'dzlcl=',dzlcl,'plcl=',plcl*0.01,'funa=',funa,'funz=',funz - !write (unit=21,fmt='(a)') '-------------------------------------------------------' - !write (unit=21,fmt='(a)') ' ' - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - else - write (unit=*,fmt='(a)') '-------------------------------------------------------' - write (unit=*,fmt='(a)') ' LCL Temperature didn''t converge!!!' - write (unit=*,fmt='(a,1x,i5,1x,a)') ' I gave up, after',maxfpo,'iterations...' - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' Input values.' - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a,1x,f12.4)' ) 'theta_il [ K] =',thil - write (unit=*,fmt='(a,1x,f12.4)' ) 'Pressure [ hPa] =',1.d-2*pres - write (unit=*,fmt='(a,1x,f12.4)' ) 'Temperature [ °C] =',temp-t008 - write (unit=*,fmt='(a,1x,f12.4)' ) 'rtot [ g/kg] =',1.d3*rtot - write (unit=*,fmt='(a,1x,f12.4)' ) 'rvpr [ g/kg] =',10.d3*rvpr - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' Last iteration outcome.' - write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcla [ °C] =',tlcla-t008 - write (unit=*,fmt='(a,1x,f12.4)' ) 'tlclz [ °C] =',tlclz-t008 - write (unit=*,fmt='(a,1x,f12.4)' ) 'fun [ K] =',funnow - write (unit=*,fmt='(a,1x,f12.4)' ) 'funa [ K] =',funa - write (unit=*,fmt='(a,1x,f12.4)' ) 'funz [ K] =',funz - write (unit=*,fmt='(a,1x,f12.4)' ) 'deriv [ ----] =',deriv - write (unit=*,fmt='(a,1x,es12.4)') 'toler [ ----] =',toler8 - write (unit=*,fmt='(a,1x,es12.4)') 'error [ ----] =' & - ,abs(tlclz-tlcla)/tlclz - write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcl [ °C] =',tlcl - call fatal_error('TLCL didn''t converge, gave up!','lcl_il8','therm_lib8.f90') - end if + + if (.not. converged) call fatal_error('Failed finding equilibrium, I gave up!' & + ,'thil2tqliq8','therm_lib8.f90') return - end subroutine lcl_il8 + end subroutine thil2tqliq8 !=======================================================================================! !=======================================================================================! @@ -3056,35 +4997,48 @@ end subroutine lcl_il8 !=======================================================================================! !=======================================================================================! ! This subroutine computes the temperature and fraction of liquid water from the ! - ! internal energy . This requires double precision arguments. ! + ! intensive internal energy [J/kg]. ! !---------------------------------------------------------------------------------------! - subroutine qtk8(q,tempk,fracliq) - use consts_coms, only: cliqi8,cicei8,allii8,t3ple8,qicet38,qliqt38,tsupercool8 + subroutine uint2tl8(uint,temp,fliq) + use consts_coms, only : cliqi8 & ! intent(in) + , cicei8 & ! intent(in) + , allii8 & ! intent(in) + , t3ple8 & ! intent(in) + , uiicet38 & ! intent(in) + , uiliqt38 & ! intent(in) + , tsupercool_liq8 ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: q ! Internal energy [ J/kg] - real(kind=8), intent(out) :: tempk ! Temperature [ K] - real(kind=8), intent(out) :: fracliq ! Liquid Fraction (0-1) [ ---] + real(kind=8), intent(in) :: uint ! Internal energy [ J/kg] + real(kind=8), intent(out) :: temp ! Temperature [ K] + real(kind=8), intent(out) :: fliq ! Liquid Fraction (0-1) [ ---] !------------------------------------------------------------------------------------! - !----- Internal energy below qwfroz, all ice ---------------------------------------! - if (q <= dble(qicet38)) then - fracliq = 0.d0 - tempk = q * cicei8 - !----- Internal energy, above qwmelt, all liquid ------------------------------------! - elseif (q >= dble(qliqt38)) then - fracliq = 1.d0 - tempk = q * cliqi8 + tsupercool8 - !----- Changing phase, it must be at freezing point ---------------------------------! + !------------------------------------------------------------------------------------! + ! Compare the internal energy with the reference values to decide which phase ! + ! the water is. ! + !------------------------------------------------------------------------------------! + if (uint <= uiicet38) then + !----- Internal energy below qwfroz, all ice ------------------------------------! + fliq = 0.d0 + temp = uint * cicei8 + !---------------------------------------------------------------------------------! + elseif (uint >= uiliqt38) then + !----- Internal energy, above qwmelt, all liquid ---------------------------------! + fliq = 1.d0 + temp = uint * cliqi8 + tsupercool_liq8 + !---------------------------------------------------------------------------------! else - fracliq = (q-qicet38) * allii8 - tempk = t3ple8 - endif + !----- Changing phase, it must be at freezing point ------------------------------! + fliq = (uint - uiicet38) * allii8 + temp = t3ple8 + !---------------------------------------------------------------------------------! + end if !------------------------------------------------------------------------------------! return - end subroutine qtk8 + end subroutine uint2tl8 !=======================================================================================! !=======================================================================================! @@ -3095,66 +5049,81 @@ end subroutine qtk8 !=======================================================================================! !=======================================================================================! - ! This subroutine computes the temperature (Kelvin) and liquid fraction from inter- ! - ! nal energy (J/m² or J/m³), mass (kg/m² or kg/m³), and heat capacity (J/m²/K or ! - ! J/m³/K). ! - ! This routine requires an 8-byte double precision floating point value for density. ! + ! This subroutine computes the temperature (Kelvin) and liquid fraction from ! + ! extensive internal energy (J/m² or J/m³), water mass (kg/m² or kg/m³), and heat ! + ! capacity (J/m²/K or J/m³/K). ! !---------------------------------------------------------------------------------------! - subroutine qwtk8(qw,w,dryhcap,tempk,fracliq) - use consts_coms, only: cliqi8,cliq8,cicei8,cice8,allii8,alli8,t3ple8,tsupercool8 + subroutine uextcm2tl8(uext,wmass,dryhcap,temp,fliq) + use consts_coms, only : cliqi8 & ! intent(in) + , cliq8 & ! intent(in) + , cicei8 & ! intent(in) + , cice8 & ! intent(in) + , allii8 & ! intent(in) + , alli8 & ! intent(in) + , t3ple8 & ! intent(in) + , tsupercool_liq8 ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real(kind=8), intent(in) :: qw ! Internal energy [ J/m²] or [ J/m³] - real(kind=8), intent(in) :: w ! Density [ kg/m²] or [ kg/m³] - real(kind=8), intent(in) :: dryhcap ! Heat capacity, nonwater [J/m²/K] or [J/m³/K] - real(kind=8), intent(out) :: tempk ! Temperature [ K] - real(kind=8), intent(out) :: fracliq ! Liquid fraction (0-1) [ ---] + real(kind=8), intent(in) :: uext ! Extensive internal energy [ J/m²] or [ J/m³] + real(kind=8), intent(in) :: wmass ! Water mass [ kg/m²] or [ kg/m³] + real(kind=8), intent(in) :: dryhcap ! Heat cap. of "dry" part [J/m²/K] or [J/m³/K] + real(kind=8), intent(out) :: temp ! Temperature [ K] + real(kind=8), intent(out) :: fliq ! Liquid fraction (0-1) [ ---] !----- Local variable ---------------------------------------------------------------! - real(kind=8) :: qwfroz ! qw of ice at triple pt. [ J/m²] or [ J/m³] - real(kind=8) :: qwmelt ! qw of liquid at triple pt.[ J/m²] or [ J/m³] + real(kind=8) :: uefroz ! qw of ice at triple pt. [ J/m²] or [ J/m³] + real(kind=8) :: uemelt ! qw of liq. at triple pt. [ J/m²] or [ J/m³] !------------------------------------------------------------------------------------! - !----- Converting melting heat to J/m² or J/m³ --------------------------------------! - qwfroz = (dryhcap + w*cice8) * t3ple8 - qwmelt = qwfroz + w*alli8 - !------------------------------------------------------------------------------------! - - !------------------------------------------------------------------------------------! - ! This is analogous to the qtk computation, we should analyse the magnitude of ! - ! the internal energy to choose between liquid, ice, or both by comparing with our. ! - ! know boundaries. ! - !------------------------------------------------------------------------------------! - !----- Internal energy below qwfroz, all ice ---------------------------------------! - if (qw < qwfroz) then - fracliq = 0.d0 - tempk = qw / (cice8 * w + dryhcap) - !----- Internal energy, above qwmelt, all liquid ------------------------------------! - elseif (qw > qwmelt) then - fracliq = 1.d0 - tempk = (qw + w * cliq8 * tsupercool8) / (dryhcap + w*cliq8) - !------------------------------------------------------------------------------------! - ! We are at the freezing point. If water mass is so tiny that the internal ! - ! energy of frozen and melted states are the same given the machine precision, then ! - ! we assume that water content is negligible and we impose 50% frozen for ! - ! simplicity. ! + + !----- Convert melting heat to J/m² or J/m³ -----------------------------------------! + uefroz = (dryhcap + wmass * cice8) * t3ple8 + uemelt = uefroz + wmass * alli8 !------------------------------------------------------------------------------------! - elseif (qwfroz == qwmelt) then - fracliq = 5.d-1 - tempk = t3ple8 + + + !------------------------------------------------------------------------------------! - ! Changing phase, it must be at freezing point. The max and min are here just to ! - ! avoid tiny deviations beyond 0. and 1. due to floating point arithmetics. ! + ! This is analogous to the uint2tl8 computation, we should analyse the magnitude ! + ! of the internal energy to choose between liquid, ice, or both by comparing with ! + ! the known boundaries. ! !------------------------------------------------------------------------------------! + if (uext < uefroz) then + !----- Internal energy below qwfroz, all ice ------------------------------------! + fliq = 0.d0 + temp = uext / (cice8 * wmass + dryhcap) + !---------------------------------------------------------------------------------! + elseif (uext > uemelt) then + !----- Internal energy, above qwmelt, all liquid ---------------------------------! + fliq = 1.d0 + temp = (uext + wmass * cliq8 * tsupercool_liq8) / (dryhcap + wmass * cliq8) + !---------------------------------------------------------------------------------! + elseif (uefroz == uemelt) then + !---------------------------------------------------------------------------------! + ! We are at the freezing point. If water mass is so tiny that the internal ! + ! energy of frozen and melted states are the same given the machine precision, ! + ! then we assume that water content is negligible and we impose 50% frozen for ! + ! simplicity. ! + !---------------------------------------------------------------------------------! + fliq = 5.d-1 + temp = t3ple8 + !---------------------------------------------------------------------------------! else - fracliq = min(1.d0,max(0.d0,(qw - qwfroz) * allii8 / w)) - tempk = t3ple8 + !---------------------------------------------------------------------------------! + ! Changing phase, it must be at freezing point. The max and min are here just ! + ! to avoid tiny deviations beyond 0. and 1. due to floating point arithmetics. ! + !---------------------------------------------------------------------------------! + fliq = min(1.d0,max(0.d0,(uext - uefroz) * allii8 / wmass)) + temp = t3ple8 + !---------------------------------------------------------------------------------! end if !------------------------------------------------------------------------------------! return - end subroutine qwtk8 + end subroutine uextcm2tl8 !=======================================================================================! !=======================================================================================! end module therm_lib8 +!==========================================================================================! +!==========================================================================================! diff --git a/ED/src/utils/update_derived_props.f90 b/ED/src/utils/update_derived_props.f90 index 5c380023d..ce9ca5117 100644 --- a/ED/src/utils/update_derived_props.f90 +++ b/ED/src/utils/update_derived_props.f90 @@ -93,7 +93,6 @@ subroutine update_patch_derived_props(csite,lsl,prss,ipa) !----- Reset properties. ---------------------------------------------------------------! csite%veg_height(ipa) = 0.0 csite%lai(ipa) = 0.0 - csite%wpa(ipa) = 0.0 csite%wai(ipa) = 0.0 weight_sum = 0.0 csite%opencan_frac(ipa) = 1.0 @@ -110,7 +109,6 @@ subroutine update_patch_derived_props(csite,lsl,prss,ipa) !----- Update the patch-level area indices. -----------------------------------------! csite%lai(ipa) = csite%lai(ipa) + cpatch%lai(ico) - csite%wpa(ipa) = csite%wpa(ipa) + cpatch%wpa(ico) csite%wai(ipa) = csite%wai(ipa) + cpatch%wai(ico) !------------------------------------------------------------------------------------! @@ -209,8 +207,8 @@ subroutine update_patch_thermo_props(csite,ipaa,ipaz,mzg,mzs,ntext_soil) use ed_state_vars, only : sitetype ! ! structure use therm_lib , only : idealdenssh & ! function - , qwtk & ! function - , qtk ! ! function + , uextcm2tl & ! function + , uint2tl ! ! function use consts_coms , only : p00i & ! intent(in) , rocp & ! intent(in) , t00 & ! intent(in) @@ -244,16 +242,16 @@ subroutine update_patch_thermo_props(csite,ipaa,ipaz,mzg,mzs,ntext_soil) do k = 1, mzg nsoil = ntext_soil(k) soilhcap = soil(nsoil)%slcpd - call qwtk(csite%soil_energy(k,ipa),csite%soil_water(k,ipa)*wdns,soilhcap & - ,csite%soil_tempk(k,ipa),csite%soil_fracliq(k,ipa)) + call uextcm2tl(csite%soil_energy(k,ipa),csite%soil_water(k,ipa)*wdns,soilhcap & + ,csite%soil_tempk(k,ipa),csite%soil_fracliq(k,ipa)) end do !----- Update temporary surface water temperature and liquid water fraction. --------! ksn = csite%nlev_sfcwater(ipa) csite%total_sfcw_depth(ipa) = 0. do k = 1, ksn - call qtk(csite%sfcwater_energy(k,ipa),csite%sfcwater_tempk(k,ipa) & - ,csite%sfcwater_fracliq(k,ipa)) + call uint2tl(csite%sfcwater_energy(k,ipa),csite%sfcwater_tempk(k,ipa) & + ,csite%sfcwater_fracliq(k,ipa)) csite%total_sfcw_depth(ipa) = csite%total_sfcw_depth(ipa) & + csite%sfcwater_depth(k,ipa) end do @@ -399,10 +397,9 @@ subroutine read_soil_moist_temp(cgrid,igr) use soil_coms , only : soilstate_db & ! intent(in) , soil & ! intent(in) , slz ! ! intent(in) - use consts_coms , only : cliqvlme & ! intent(in) - , cicevlme & ! intent(in) - , t3ple & ! intent(in) - , tsupercool ! ! intent(in) + use consts_coms , only : wdns & ! intent(in) + , t3ple ! ! intent(in) + use therm_lib , only : cmtl2uext ! ! function use grid_coms , only : nzg & ! intent(in) , nzs & ! intent(in) , ngrids ! ! intent(in) @@ -511,20 +508,18 @@ subroutine read_soil_moist_temp(cgrid,igr) csite%soil_water(k,ipa) = max(soil(ntext)%soilcp & ,soilw2 * soil(ntext)%slmsts) endif - if(csite%soil_tempk(k,ipa) > t3ple)then - csite%soil_energy(k,ipa) = soil(ntext)%slcpd & - * csite%soil_tempk(k,ipa) & - + csite%soil_water(k,ipa) & - * cliqvlme*(csite%soil_tempk(k,ipa) & - - tsupercool) + if (csite%soil_tempk(k,ipa) > t3ple) then csite%soil_fracliq(k,ipa) = 1.0 - else - csite%soil_energy(k,ipa) = soil(ntext)%slcpd & - * csite%soil_tempk(k,ipa) & - + csite%soil_water(k,ipa) & - * cicevlme*csite%soil_tempk(k,ipa) + elseif (csite%soil_tempk(k,ipa) < t3ple) then csite%soil_fracliq(k,ipa) = 0.0 + else + csite%soil_fracliq(k,ipa) = 0.5 end if + csite%soil_energy(k,ipa) = cmtl2uext( soil(ntext)%slcpd & + , csite%soil_water(k,ipa) & + * wdns & + , csite%soil_tempk(k,ipa) & + , csite%soil_fracliq(k,ipa)) end do diff --git a/Ramspost/build/bin/2ndcomp.sh b/Ramspost/build/bin/2ndcomp.sh index d010dbc1d..e633ec6ef 100755 --- a/Ramspost/build/bin/2ndcomp.sh +++ b/Ramspost/build/bin/2ndcomp.sh @@ -22,6 +22,7 @@ rm -fv rconstants.o rconstants.mod rm -fv rgrad.o rgrad.mod rm -fv rnamel.o rnamel.mod rm -fv rnumr.o rnumr.mod +rm -fv rout_coms.o rout_coms.mod rm -fv rpost_coms.o rpost_coms.mod rm -fv rpost_dims.o rpost_dims.mod rm -fv rpost_filelist.o rpost_filelist.mod diff --git a/Ramspost/build/bin/dependency.mk b/Ramspost/build/bin/dependency.mk index 347971ac9..717114116 100644 --- a/Ramspost/build/bin/dependency.mk +++ b/Ramspost/build/bin/dependency.mk @@ -1,14 +1,14 @@ # DO NOT DELETE THIS LINE - used by make depend rcio.o: leaf_coms.mod micro_coms.mod rconstants.mod rpost_coms.mod rcio.o: rpost_dims.mod somevars.mod therm_lib.mod -rpost_main.o: brams_data.mod leaf_coms.mod misc_coms.mod rpost_coms.mod -rpost_main.o: rpost_dims.mod -rpost_misc.o: misc_coms.mod rpost_dims.mod +rpost_main.o: brams_data.mod leaf_coms.mod misc_coms.mod rconstants.mod +rpost_main.o: rout_coms.mod rpost_coms.mod rpost_dims.mod somevars.mod +rpost_misc.o: misc_coms.mod rout_coms.mod rpost_dims.mod therm_lib.mod variables.o: an_header.mod brams_data.mod leaf_coms.mod micro_coms.mod -variables.o: misc_coms.mod rconstants.mod rpost_coms.mod rpost_dims.mod -variables.o: scratch_coms.mod somevars.mod -comp_lib.o: leaf_coms.mod rconstants.mod rpost_coms.mod soil_coms.mod -comp_lib.o: somevars.mod therm_lib.mod +variables.o: misc_coms.mod rconstants.mod rout_coms.mod rpost_coms.mod +variables.o: rpost_dims.mod scratch_coms.mod somevars.mod +comp_lib.o: leaf_coms.mod rconstants.mod rout_coms.mod rpost_coms.mod +comp_lib.o: soil_coms.mod somevars.mod therm_lib.mod dted.o: /n/Moorcroft_Lab/Users/mlongo/EDBRAMS/Ramspost/src/include/utils_sub_names.h dted.o: eenviron.o: /n/Moorcroft_Lab/Users/mlongo/EDBRAMS/Ramspost/src/include/utils_sub_names.h @@ -41,6 +41,7 @@ leaf_coms.mod: leaf_coms.o micro_coms.mod: micro_coms.o misc_coms.mod: misc_coms.o rconstants.mod: rconstants.o +rout_coms.mod: rout_coms.o rpost_coms.mod: rpost_coms.o rpost_dims.mod: rpost_dims.o scratch_coms.mod: scratch_coms.o diff --git a/Ramspost/build/bin/objects.mk b/Ramspost/build/bin/objects.mk index 09fd89c06..b968c06ce 100644 --- a/Ramspost/build/bin/objects.mk +++ b/Ramspost/build/bin/objects.mk @@ -32,6 +32,7 @@ OBJECTS = \ rgrad.o \ rnamel.o \ rnumr.o \ + rout_coms.o \ rpost_coms.o \ rpost_dims.o \ rpost_filelist.o \ diff --git a/Ramspost/build/bin/rules.mk b/Ramspost/build/bin/rules.mk index ef99f239f..bc403c9d4 100644 --- a/Ramspost/build/bin/rules.mk +++ b/Ramspost/build/bin/rules.mk @@ -113,6 +113,11 @@ rnumr.o: $(RPOST_LIB)/rnumr.f90 $(F90_COMMAND) $(= iep_nz(ng)) zlevmax(ng) = iep_nz(ng)-1 + !------------------------------------------------------------------------------------! + + write (unit=*,fmt='(a,1x,i5)') ' + GRID =',ng + write (unit=*,fmt='(a,1x,i5)') ' - IEP_NX =',iep_nx(ng) + write (unit=*,fmt='(a,1x,i5)') ' - IEP_NY =',iep_ny(ng) + write (unit=*,fmt='(a,1x,i5)') ' - IEP_NZ =',iep_nz(ng) + write (unit=*,fmt='(a,1x,i5)') ' - ZLEVMAX =',zlevmax(ng) + end do + write (unit=*,fmt='(92a)' ) ('-',n=1,92) + write (unit=*,fmt='(a)' ) ' ' + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! Determine the initial time, the time step, and the best units for time interval. ! + !---------------------------------------------------------------------------------------! + call RAMS_get_time_init(1,iyear,imonth,idate,ihour,imin) + call RAMS_get_time_step(iistep,hunit,nfiles) + write(chdate,fmt='(3(i2.2,a),i4.4)') ihour,':',imin,'z',idate,cmo(imonth),iyear + write(chstep,fmt='(8x,i3,a)') iistep,trim(ctu(hunit)) + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! Allocate the output buffer structures. ! + !---------------------------------------------------------------------------------------! + allocate (rout (iep_ngrids)) + allocate (routgrads(iep_ngrids)) + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! Grid loop. ! + !---------------------------------------------------------------------------------------! + gridloop: do ng=1,iep_ngrids + write (unit=*,fmt='(92a)' ) ('=',n=1,92) + write (unit=*,fmt='(a)' ) ' ' + write (unit=*,fmt='(a,1x,i5)') ' + Writing Grid ',ng + + + !------------------------------------------------------------------------------------! + ! Allocate pointers from rout and routgrads. ! + !------------------------------------------------------------------------------------! + call alloc_rout(rout(ng),iep_nx(ng),iep_ny(ng),iep_nz(ng),iep_ng,iep_np,iep_nc & + ,inplevs) + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Initialise NNVP with the number of variables coming from the namelist. In case ! + ! it is a multiple-class variable, the actual number of output variables will ! + ! increase. Conversely, if the user asked for a variable that doesn't exist, we ! + ! take one number out and warn him/her. ! + !------------------------------------------------------------------------------------! + nnvp = nvp + !------------------------------------------------------------------------------------! + + write(cgrid,'(i1)') ng + + iv = 1 + + !----- Get the prefix and remove the trailing -head.txt so we can append grid info. -! + cfln = trim(fln(1)) + ip = len_trim(cfln) - 9 + cfln = cfln(1:ip) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Read latitude and longitude of the "thermodynamic points" of BRAMS. Save them ! + ! to rlat and rlon, respectively. ! + !------------------------------------------------------------------------------------! + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(2(a,1x))') ' - Variable: ','lat' + + call ep_getvar('lat',iep_nx(ng),iep_ny(ng),1,ng,cfln,vpln(iv),vpun(iv),n,iep_np & + ,iep_nc,iep_ng) + call atob(iep_nx(ng)*iep_ny(ng),rout(ng)%r2,rout(ng)%rlat) + write(unit=*,fmt='(a,1x,i5)') ' # Output variable type: ',n + + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(2(a,1x))') ' - Variable: ','lon' + + call ep_getvar('lon',iep_nx(ng),iep_ny(ng),1,ng,cfln ,vpln(iv),vpun(iv),n,iep_np & + ,iep_nc,iep_ng) + call atob(iep_nx(ng)*iep_ny(ng),rout(ng)%r2,rout(ng)%rlon) + write(unit=*,fmt='(a,1x,i5)') ' # Output variable type: ',n + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the dimensions of x and y domains depending on the sought projection, and ! + ! find the mapping to interpolate values to the regular lon-lat grid if needed. ! + !------------------------------------------------------------------------------------! + call geo_grid(iep_nx(ng),iep_ny(ng),rout(ng)%rlat,rout(ng)%rlon,dep_glon(1,ng) & + ,dep_glon(2,ng),dep_glat(1,ng),dep_glat(2,ng),rlatmin,rlatmax,rlonmin & + ,rlonmax,nxgrads(ng),nygrads(ng),proj) + call alloc_rout(routgrads(ng),nxgrads(ng),nygrads(ng),iep_nz(ng),iep_ng,iep_np & + ,iep_nc,inplevs) + call array_interpol(ng,nxgrads(ng),nygrads(ng),iep_nx(ng),iep_ny(ng),dep_glat(1,ng) & + ,dep_glat(2,ng),dep_glon(1,ng),dep_glon(2,ng),routgrads(ng)%iinf & + ,routgrads(ng)%jinf,routgrads(ng)%rmi,proj) + call define_lim(ng,nxgrads(ng),nygrads(ng),dep_glat(1,ng),dep_glat(2,ng) & + ,dep_glon(1,ng),dep_glon(2,ng),lati(ng),latf(ng),loni(ng),lonf(ng) & + ,nxa(ng),nxb(ng),nya(ng),nyb(ng),proj,iep_nx(ng),iep_ny(ng) & + ,rout(ng)%rlat,rout(ng)%rlon) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Open the binary file now. ! + !------------------------------------------------------------------------------------! + open(unit=19,file=trim(gprefix)//'_g'//cgrid//'.gra',form='unformatted' & + ,access='direct',status='replace',action='write' & + ,recl=4*(nxb(ng)-nxa(ng)+1)*(nyb(ng)-nya(ng)+1)) + nrec = 0 + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Loop over all files that are to be used. ! + !------------------------------------------------------------------------------------! + fileloop: do nfn=1,nfiles,nstep + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(a,1x,i5)') ' - Timestep: ',nfn + + !---------------------------------------------------------------------------------! + ! Get the prefix and remove the trailing -head.txt so we can append grid ! + ! info. ! + !---------------------------------------------------------------------------------! + cfln = trim(fln(nfn)) + ip = len_trim(cfln) - 9 + cfln = cfln(1:ip) + !---------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------! + ! In case ipresslev is not zero (vertical intepolation), we must load ! + ! topography and Exner function so we can interpolate variables. ! + !---------------------------------------------------------------------------------! + select case (ipresslev) + case (0) + continue + case default + !----- Load topography. -------------------------------------------------------! + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(2(a,1x))') ' * Variable: ','topo' + call ep_getvar('topo',iep_nx(ng),iep_ny(ng),1,ng,cfln,vpln(iv),vpun(iv),n & + ,iep_np,iep_nc,iep_ng) + call atob(iep_nx(ng)*iep_ny(ng),rout(ng)%r2,rout(ng)%topo) + write(unit=*,fmt='(a,1x,i5)') ' # Output variable type: ',n + !------------------------------------------------------------------------------! + + !----- Load Exner function. ---------------------------------------------------! + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(2(a,1x))') ' * Variable: ','pi' + call ep_getvar('pi',iep_nx(ng),iep_ny(ng),iep_nz(ng),ng,cfln,vpln(iv),vpun(iv) & + ,n,iep_np,iep_nc,iep_ng) + call atob(iep_nx(ng)*iep_ny(ng)*iep_nz(ng),rout(ng)%r3,rout(ng)%exner) + write(unit=*,fmt='(a,1x,i5)') ' # Output variable type: ',n + !------------------------------------------------------------------------------! + end select + !---------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------! + ! Loop over all other variables. ! + !---------------------------------------------------------------------------------! + varloop: do iv=1,nvp + call undef_rout(rout(ng) ,.false.) + call undef_rout(routgrads(ng),.false.) + write(unit=*,fmt='(a)') ' ' + write(unit=*,fmt='(2(a,1x))') ' * Variable: ',trim(vp(iv)) + call ep_getvar(trim(vp(iv)),iep_nx(ng),iep_ny(ng),iep_nz(ng),ng,cfln,vpln(iv) & + ,vpun(iv),ndim(iv),iep_np,iep_nc,iep_ng) + write(unit=*,fmt='(a,1x,i5)') ' # Output variable type: ',ndim(iv) + + + !------------------------------------------------------------------------------! + ! Decide how to output variable depending on the variable type. ! + !------------------------------------------------------------------------------! + select case (ndim(iv)) + case (2) + !---------------------------------------------------------------------------! + ! Two-dimensional array, no vertical information. ! + !---------------------------------------------------------------------------! + + + !----- Set the number of levels. -------------------------------------------! + nzvp(iv) = 1 + !---------------------------------------------------------------------------! + + + !----- Adjust projection to GrADS. -----------------------------------------! + call proj_rams_to_grads(vp(iv),ndim(iv),iep_nx(ng),iep_ny(ng),nzvp(iv) & + ,nxgrads(ng),nygrads(ng),routgrads(ng)%rmi & + ,routgrads(ng)%iinf,routgrads(ng)%jinf,rout(ng)%r2 & + ,routgrads(ng)%r2,rout(ng)%rlat,rout(ng)%rlon,proj) + !---------------------------------------------------------------------------! + + + !----- Dump array to output file. ------------------------------------------! + call ep_putvar(19,nxgrads(ng),nygrads(ng),nzvp(iv),nxa(ng),nxb(ng),nya(ng) & + ,nyb(ng),1,1,routgrads(ng)%r2,nrec) + !---------------------------------------------------------------------------! + case (3) + !---------------------------------------------------------------------------! + ! Three-dimensional array. ! + !---------------------------------------------------------------------------! + + + !----- Set the number of levels. -------------------------------------------! + nzvp(iv) = iep_nz(ng) + !---------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------! + ! Decide which vertical levels to use. ! + !---------------------------------------------------------------------------! + select case (ipresslev) + case (0) + !------------------------------------------------------------------------! + ! Native coordinates. ! + !------------------------------------------------------------------------! + + !----- Adjust projection to GrADS. --------------------------------------! + call proj_rams_to_grads(vp(iv),ndim(iv),iep_nx(ng),iep_ny(ng),nzvp(iv) & + ,nxgrads(ng),nygrads(ng),routgrads(ng)%rmi & + ,routgrads(ng)%iinf,routgrads(ng)%jinf & + ,rout(ng)%r3,routgrads(ng)%r3,rout(ng)%rlat & + ,rout(ng)%rlon,proj) + !------------------------------------------------------------------------! + + !----- Dump array to output file. ---------------------------------------! + call ep_putvar(19,nxgrads(ng),nygrads(ng),nzvp(iv),nxa(ng),nxb(ng) & + ,nya(ng),nyb(ng),2,zlevmax(ng)+1,routgrads(ng)%r3,nrec) + !------------------------------------------------------------------------! + case (1) + !------------------------------------------------------------------------! + ! Pressure levels. ! + !------------------------------------------------------------------------! + + !----- Set the number of levels. ----------------------------------------! + inplevsef = inplevs + !------------------------------------------------------------------------! + + !----- Interpolate to pressure levels. ----------------------------------! + call ptransvar(rout(ng)%r3,iep_nx(ng),iep_ny(ng),nzvp(iv),inplevs & + ,iplevs,rout(ng)%exner,dep_zlev(:,ng),rout(ng)%zplev & + ,rout(ng)%topo) + !------------------------------------------------------------------------! + + + !----- Adjust projection to GrADS. --------------------------------------! + call proj_rams_to_grads(vp(iv),ndim(iv),iep_nx(ng),iep_ny(ng),nzvp(iv) & + ,nxgrads(ng),nygrads(ng),routgrads(ng)%rmi & + ,routgrads(ng)%iinf,routgrads(ng)%jinf & + ,rout(ng)%r3,routgrads(ng)%r3,rout(ng)%rlat & + ,rout(ng)%rlon,proj) + !------------------------------------------------------------------------! + + !----- Dump array to output file. ---------------------------------------! + call ep_putvar(19,nxgrads(ng),nygrads(ng),inplevsef,nxa(ng),nxb(ng) & + ,nya(ng),nyb(ng),1,inplevsef,routgrads(ng)%r3,nrec) + !------------------------------------------------------------------------! + case (2) + !------------------------------------------------------------------------! + ! Height levels. ! + !------------------------------------------------------------------------! + + !----- Set the number of levels. ----------------------------------------! + inplevsef = inplevs + !------------------------------------------------------------------------! + + !----- Interpolate to height levels. ------------------------------------! + call ctransvar(iep_nx(ng),iep_ny(ng),iep_nz(ng),rout(ng)%r3 & + ,rout(ng)%topo,inplevs,iplevs,myztn(:,ng) & + ,myzmn(mynnzp(1)-1,1)) + !------------------------------------------------------------------------! + + + !----- Adjust projection to GrADS. --------------------------------------! + call proj_rams_to_grads(vp(iv),ndim(iv),iep_nx(ng),iep_ny(ng),nzvp(iv) & + ,nxgrads(ng),nygrads(ng),routgrads(ng)%rmi & + ,routgrads(ng)%iinf,routgrads(ng)%jinf & + ,rout(ng)%r3,routgrads(ng)%r3,rout(ng)%rlat & + ,rout(ng)%rlon,proj) + !------------------------------------------------------------------------! + + + !----- Dump array to output file. ---------------------------------------! + call ep_putvar(19,nxgrads(ng),nygrads(ng),inplevsef,nxa(ng),nxb(ng) & + ,nya(ng),nyb(ng),1,inplevsef,routgrads(ng)%r3,nrec) + !------------------------------------------------------------------------! + case (3) + !------------------------------------------------------------------------! + ! Selected sigma-z levels. ! + !------------------------------------------------------------------------! + + !----- Set the number of levels. ----------------------------------------! + inplevsef = inplevs + !------------------------------------------------------------------------! + + !----- Pick only the levels we are interested in. -----------------------! + call select_sigmaz(iep_nx(ng),iep_ny(ng),iep_nz(ng),rout(ng)%r3 & + ,inplevs,iplevs) + !------------------------------------------------------------------------! + + + !----- Adjust projection to GrADS. --------------------------------------! + call proj_rams_to_grads(vp(iv),ndim(iv),iep_nx(ng),iep_ny(ng),nzvp(iv) & + ,nxgrads(ng),nygrads(ng),routgrads(ng)%rmi & + ,routgrads(ng)%iinf,routgrads(ng)%jinf & + ,rout(ng)%r3,routgrads(ng)%r3,rout(ng)%rlat & + ,rout(ng)%rlon,proj) + !------------------------------------------------------------------------! + + + !----- Dump array to output file. ---------------------------------------! + call ep_putvar(19,nxgrads(ng),nygrads(ng),inplevsef,nxa(ng),nxb(ng) & + ,nya(ng),nyb(ng),1,inplevsef,routgrads(ng)%r3,nrec) + !------------------------------------------------------------------------! + + end select + + case (6) + !---------------------------------------------------------------------------! + ! Four-dimensional array, fourth dimension is the cloud-level. We will ! + ! save these as independent variables. Like in the 3-D case, we must also ! + ! decide which vertical levels to plot. ! + !---------------------------------------------------------------------------! + + !----- Update the number of variables. -------------------------------------! + if (nfn == 1) nnvp = nnvp + iep_nc - 1 + !---------------------------------------------------------------------------! + + + !----- Set the number of levels. -------------------------------------------! + nzvp(iv) = iep_nz(ng) + !---------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------! + ! Decide which vertical levels to use. ! + !---------------------------------------------------------------------------! + select case (ipresslev) + case (0) + !------------------------------------------------------------------------! + ! Native coordinates. ! + !------------------------------------------------------------------------! + + + !------------------------------------------------------------------------! + ! Loop over clouds. ! + !------------------------------------------------------------------------! + do ic = 1,iep_nc + !----- Convert the 4D array into a 3D. -------------------------------! + call s4d_to_3d(iep_nx(ng),iep_ny(ng),nzvp(iv),iep_nc,ic & + ,rout(ng)%r6,rout(ng)%r3) + !---------------------------------------------------------------------! + + + !----- Adjust projection to GrADS. -----------------------------------! + call proj_rams_to_grads(vp(iv),ndim(iv),iep_nx(ng),iep_ny(ng) & + ,nzvp(iv),nxgrads(ng),nygrads(ng) & + ,routgrads(ng)%rmi,routgrads(ng)%iinf & + ,routgrads(ng)%jinf,rout(ng)%r3 & + ,routgrads(ng)%r3,rout(ng)%rlat,rout(ng)%rlon & + ,proj) + !---------------------------------------------------------------------! + + !----- Dump array to output file. ------------------------------------! + call ep_putvar(19,nxgrads(ng),nygrads(ng),nzvp(iv),nxa(ng),nxb(ng) & + ,nya(ng),nyb(ng),2,zlevmax(ng)+1,routgrads(ng)%r3,nrec) + !---------------------------------------------------------------------! + end do + !------------------------------------------------------------------------! + + case (1) + !------------------------------------------------------------------------! + ! Pressure levels. ! + !------------------------------------------------------------------------! + + !----- Set the number of levels. ----------------------------------------! + inplevsef = inplevs + !------------------------------------------------------------------------! + + + !------------------------------------------------------------------------! + ! Loop over clouds. ! + !------------------------------------------------------------------------! + do ic = 1,iep_nc + !----- Convert the 4D array into a 3D. -------------------------------! + call s4d_to_3d(iep_nx(ng),iep_ny(ng),nzvp(iv),iep_nc,ic & + ,rout(ng)%r6,rout(ng)%r3) + !---------------------------------------------------------------------! + + !----- Interpolate to pressure levels. -------------------------------! + call ptransvar(rout(ng)%r3,iep_nx(ng),iep_ny(ng),nzvp(iv),inplevs & + ,iplevs,rout(ng)%exner,dep_zlev(:,ng),rout(ng)%zplev & + ,rout(ng)%topo) + !---------------------------------------------------------------------! + + + !----- Adjust projection to GrADS. -----------------------------------! + call proj_rams_to_grads(vp(iv),ndim(iv),iep_nx(ng),iep_ny(ng) & + ,nzvp(iv),nxgrads(ng),nygrads(ng) & + ,routgrads(ng)%rmi,routgrads(ng)%iinf & + ,routgrads(ng)%jinf,rout(ng)%r3 & + ,routgrads(ng)%r3,rout(ng)%rlat,rout(ng)%rlon & + ,proj) + !---------------------------------------------------------------------! + + !----- Dump array to output file. ------------------------------------! + call ep_putvar(19,nxgrads(ng),nygrads(ng),inplevsef,nxa(ng),nxb(ng) & + ,nya(ng),nyb(ng),1,inplevsef,routgrads(ng)%r3,nrec) + !---------------------------------------------------------------------! + end do + !------------------------------------------------------------------------! + + case (2) + !------------------------------------------------------------------------! + ! Height levels. ! + !------------------------------------------------------------------------! + + !----- Set the number of levels. ----------------------------------------! + inplevsef = inplevs + !------------------------------------------------------------------------! + + + !------------------------------------------------------------------------! + ! Loop over clouds. ! + !------------------------------------------------------------------------! + do ic = 1,iep_nc + !----- Convert the 4D array into a 3D. -------------------------------! + call s4d_to_3d(iep_nx(ng),iep_ny(ng),nzvp(iv),iep_nc,ic & + ,rout(ng)%r6,rout(ng)%r3) + !---------------------------------------------------------------------! + + !----- Interpolate to height levels. ---------------------------------! + call ctransvar(iep_nx(ng),iep_ny(ng),iep_nz(ng),rout(ng)%r3 & + ,rout(ng)%topo,inplevs,iplevs,myztn(:,ng) & + ,myzmn(mynnzp(1)-1,1)) + !---------------------------------------------------------------------! + + + !----- Adjust projection to GrADS. -----------------------------------! + call proj_rams_to_grads(vp(iv),ndim(iv),iep_nx(ng),iep_ny(ng) & + ,nzvp(iv),nxgrads(ng),nygrads(ng) & + ,routgrads(ng)%rmi,routgrads(ng)%iinf & + ,routgrads(ng)%jinf,rout(ng)%r3 & + ,routgrads(ng)%r3,rout(ng)%rlat,rout(ng)%rlon & + ,proj) + !---------------------------------------------------------------------! + + + !----- Dump array to output file. ------------------------------------! + call ep_putvar(19,nxgrads(ng),nygrads(ng),inplevsef,nxa(ng),nxb(ng) & + ,nya(ng),nyb(ng),1,inplevsef,routgrads(ng)%r3,nrec) + !---------------------------------------------------------------------! + end do + !------------------------------------------------------------------------! + case (3) + !------------------------------------------------------------------------! + ! Selected sigma-z levels. ! + !------------------------------------------------------------------------! + + !----- Set the number of levels. ----------------------------------------! + inplevsef = inplevs + !------------------------------------------------------------------------! + + + !------------------------------------------------------------------------! + ! Loop over clouds. ! + !------------------------------------------------------------------------! + do ic = 1,iep_nc + !----- Convert the 4D array into a 3D. -------------------------------! + call s4d_to_3d(iep_nx(ng),iep_ny(ng),nzvp(iv),iep_nc,ic & + ,rout(ng)%r6,rout(ng)%r3) + !---------------------------------------------------------------------! + + !----- Pick only the levels we are interested in. --------------------! + call select_sigmaz(iep_nx(ng),iep_ny(ng),iep_nz(ng),rout(ng)%r3 & + ,inplevs,iplevs) + !---------------------------------------------------------------------! + + + !----- Adjust projection to GrADS. -----------------------------------! + call proj_rams_to_grads(vp(iv),ndim(iv),iep_nx(ng),iep_ny(ng) & + ,nzvp(iv),nxgrads(ng),nygrads(ng) & + ,routgrads(ng)%rmi,routgrads(ng)%iinf & + ,routgrads(ng)%jinf,rout(ng)%r3 & + ,routgrads(ng)%r3,rout(ng)%rlat,rout(ng)%rlon & + ,proj) + !---------------------------------------------------------------------! + + + !----- Dump array to output file. ------------------------------------! + call ep_putvar(19,nxgrads(ng),nygrads(ng),inplevsef,nxa(ng),nxb(ng) & + ,nya(ng),nyb(ng),1,inplevsef,routgrads(ng)%r3,nrec) + !---------------------------------------------------------------------! + end do + !------------------------------------------------------------------------! + + end select + case (7) + !---------------------------------------------------------------------------! + ! Three-dimensional array, third dimension is the patch-level. We will ! + ! save these as independent variables. ! + !---------------------------------------------------------------------------! + + !----- Update the number of variables. -------------------------------------! + if (nfn == 1) nnvp = nnvp + iep_np - 1 + !---------------------------------------------------------------------------! + + !----- Set the number of levels. -------------------------------------------! + nzvp(iv) = iep_np + !---------------------------------------------------------------------------! + + + !----- Adjust projection to GrADS. -----------------------------------------! + call proj_rams_to_grads(vp(iv),ndim(iv),iep_nx(ng),iep_ny(ng),nzvp(iv) & + ,nxgrads(ng),nygrads(ng),routgrads(ng)%rmi & + ,routgrads(ng)%iinf,routgrads(ng)%jinf,rout(ng)%r7 & + ,routgrads(ng)%r7,rout(ng)%rlat,rout(ng)%rlon,proj) + !---------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------! + ! Loop over all patches, and write the 2-D arrays. ! + !---------------------------------------------------------------------------! + do ip=1,iep_np + call ep_putvar(19,nxgrads(ng),nygrads(ng),nzvp(iv),nxa(ng),nxb(ng) & + ,nya(ng),nyb(ng),ip,ip,routgrads(ng)%r7,nrec) + end do + !---------------------------------------------------------------------------! + + case (8) + !---------------------------------------------------------------------------! + ! Soil variable that has layers and patches. ! + !---------------------------------------------------------------------------! + + + !----- Update the number of variables. -------------------------------------! + if (nfn == 1) nnvp = nnvp + iep_np - 1 + !---------------------------------------------------------------------------! + + + !----- Set the number of levels. -------------------------------------------! + nzvp(iv) = iep_ng + !---------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------! + ! Loop over patches. ! + !---------------------------------------------------------------------------! + do ip = 1,iep_np + !----- Convert the 4D array into a 3D. ----------------------------------! + call s4d_to_3d(iep_nx(ng),iep_ny(ng),nzvp(iv),iep_np,ip & + ,rout(ng)%r8,rout(ng)%r10) + !------------------------------------------------------------------------! + + + !----- Adjust projection to GrADS. --------------------------------------! + call proj_rams_to_grads(vp(iv),ndim(iv),iep_nx(ng),iep_ny(ng),nzvp(iv) & + ,nxgrads(ng),nygrads(ng),routgrads(ng)%rmi & + ,routgrads(ng)%iinf,routgrads(ng)%jinf & + ,rout(ng)%r10,routgrads(ng)%r10,rout(ng)%rlat & + ,rout(ng)%rlon,proj) + !------------------------------------------------------------------------! + + + !----- Dump array to output file. ---------------------------------------! + call ep_putvar(19,nxgrads(ng),nygrads(ng),nzvp(iv),nxa(ng),nxb(ng) & + ,nya(ng),nyb(ng),1,iep_ng,routgrads(ng)%r10,nrec) + !------------------------------------------------------------------------! + end do + !---------------------------------------------------------------------------! + + case (9) + !---------------------------------------------------------------------------! + ! Three-dimensional array, third dimension is the cloud-level. We will ! + ! save these as independent variables. ! + !---------------------------------------------------------------------------! + + + !----- Update the number of variables. -------------------------------------! + if (nfn == 1) nnvp = nnvp + iep_nc - 1 + !---------------------------------------------------------------------------! + + + !----- Set the number of levels. -------------------------------------------! + nzvp(iv) = iep_nc + !---------------------------------------------------------------------------! + + + !----- Adjust projection to GrADS. -----------------------------------------! + call proj_rams_to_grads(vp(iv),ndim(iv),iep_nx(ng),iep_ny(ng),nzvp(iv) & + ,nxgrads(ng),nygrads(ng),routgrads(ng)%rmi & + ,routgrads(ng)%iinf,routgrads(ng)%jinf,rout(ng)%r9 & + ,routgrads(ng)%r9,rout(ng)%rlat,rout(ng)%rlon,proj) + !---------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------! + ! Loop over all clouds, and write the 2-D arrays. ! + !---------------------------------------------------------------------------! + do ic=1,iep_nc + call ep_putvar(19,nxgrads(ng),nygrads(ng),nzvp(iv),nxa(ng),nxb(ng) & + ,nya(ng),nyb(ng),ic,ic,routgrads(ng)%r9,nrec) + end do + !---------------------------------------------------------------------------! + + case (10) + !---------------------------------------------------------------------------! + ! Soil variable that has layers but no patches. ! + !---------------------------------------------------------------------------! + !----- Set the number of levels. -------------------------------------------! + nzvp(iv) = iep_ng + !---------------------------------------------------------------------------! + + + !----- Adjust projection to GrADS. -----------------------------------------! + call proj_rams_to_grads(vp(iv),ndim(iv),iep_nx(ng),iep_ny(ng),nzvp(iv) & + ,nxgrads(ng),nygrads(ng),routgrads(ng)%rmi & + ,routgrads(ng)%iinf,routgrads(ng)%jinf,rout(ng)%r10 & + ,routgrads(ng)%r10,rout(ng)%rlat,rout(ng)%rlon,proj) + !---------------------------------------------------------------------------! + + + !----- Dump array to output file. ------------------------------------------! + call ep_putvar(19,nxgrads(ng),nygrads(ng),nzvp(iv),nxa(ng),nxb(ng) & + ,nya(ng),nyb(ng),1,nzvp(iv),routgrads(ng)%r10,nrec) + !---------------------------------------------------------------------------! + + case default + !------ Invalid variable, remove one from the total count. -----------------! + if (nfn == 1) nnvp=nnvp-1 + !---------------------------------------------------------------------------! + end select + !------------------------------------------------------------------------------! + end do varloop + !---------------------------------------------------------------------------------! + end do fileloop + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Close the binary file now. ! + !------------------------------------------------------------------------------------! + close (unit=19,status='keep') + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Define the number of output grid points in X and Y. ! + !------------------------------------------------------------------------------------! + nxpg = nxb(ng) - nxa(ng) + 1 + nypg= nyb(ng) - nya(ng) + 1 + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Open the CTL file and start writing the header. ! + !------------------------------------------------------------------------------------! + open (unit=20,file=trim(gprefix)//'_g'//cgrid//'.ctl',status='replace' & + ,action='write') + write(unit=20,fmt='(a)') 'dset ^'//trim(gprefix)//'_g'//cgrid//'.gra' + write(unit=20,fmt='(a,1x,es10.3)') 'undef',undefflg + write(unit=20,fmt='(a)') 'title BRAMS-4.0.6 output' + write(unit=20,fmt='(a,1x,i5,1x,a,2(1x,f14.5))') 'xdef',nxpg,'linear' & + ,dep_glon(1,ng),dep_glon(2,ng) + write(unit=20,fmt='(a,1x,i5,1x,a,2(1x,f14.5))') 'ydef',nypg,'linear' & + ,dep_glat(1,ng),dep_glat(2,ng) + + !------------------------------------------------------------------------------------! + ! Write the vertical coordinates. ! + !------------------------------------------------------------------------------------! + select case (ipresslev) + case (0) + !----- Native coordinates. Break it in case there are more than 15 lines. -------! + if (zlevmax(ng) > 15) then + write (unit=20,fmt='(a,1x,i5,1x,a,15(1x,f14.5))') 'zdef',zlevmax(ng),'levels' & + ,(dep_zlev(n,ng),n=2,15) + write (unit=20,fmt='(200(1x,f14.5))') (dep_zlev(n,ng),n=16,zlevmax(ng)+1) + else + write (unit=20,fmt='(a,1x,i5,1x,a,200(1x,f14.5))') 'zdef',zlevmax(ng),'levels' & + ,(dep_zlev(n,ng),n=2,zlevmax(ng)+1) + end if + !---------------------------------------------------------------------------------! + case (1,2) + !----- Pressure or height coordinates. ------------------------------------------! + write (unit=20,fmt='(a,1x,i5,1x,a,200(1x,f14.5))') 'zdef',inplevs,'levels' & + ,(iplevs(n)*1.0,n=1,inplevs) + !---------------------------------------------------------------------------------! + case (3) + !----- Selected sigma-z coordinates. --------------------------------------------! + write (unit=20,fmt='(a,1x,i5,1x,a,200(1x,f14.5))') 'zdef',inplevs,'levels' & + ,(dep_zlev(iplevs(n),ng),n=1,inplevs) + !---------------------------------------------------------------------------------! + end select + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Write time. ! + !------------------------------------------------------------------------------------! + write(unit=20,fmt='(a,1x,i5,3(1x,a))') 'tdef',nfiles,'linear',chdate,chstep + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Loop over variables. ! + !------------------------------------------------------------------------------------! + write(unit=20,fmt='(a,1x,i5)') 'vars',nnvp + varoutloop: do iv=1,nvp + select case (ndim(iv)) + case (2) + !------------------------------------------------------------------------------! + ! 2 D variable, no height reference. ! + !------------------------------------------------------------------------------! + write(unit=20,fmt='(a,2(1x,i5),4(1x,a))') vp(iv),0,99,vpln(iv) & + ,'[',vpun(iv),']' + case (3) + !------------------------------------------------------------------------------! + ! 3 D variable. Check which vertical coordinate to use. ! + !------------------------------------------------------------------------------! + select case (ipresslev) + case (0) + !----- Native coordinates. -------------------------------------------------! + write(unit=20,fmt='(a,2(1x,i5),4(1x,a))') vp(iv),zlevmax(ng),99,vpln(iv) & + ,'[',vpun(iv),']' + case default + !----- Other coordinates. --------------------------------------------------! + write(unit=20,fmt='(a,2(1x,i5),4(1x,a))') vp(iv),inplevs,99,vpln(iv) & + ,'[',vpun(iv),']' + end select + !------------------------------------------------------------------------------! + case (6) + !------------------------------------------------------------------------------! + ! 4 D variable. Make one entry per cloud, and check which vertical ! + ! coordinate to use. ! + !------------------------------------------------------------------------------! + do ic = 1, iep_nc + write(cldnumber,fmt='(i2.2)') ic + tmpvar = trim(vp(iv))//cldnumber + tmpdesc = trim(vpln(iv))//': Cloud # '//cldnumber + !---------------------------------------------------------------------------! + ! Check which vertical coordinate to use. ! + !---------------------------------------------------------------------------! + select case (ipresslev) + case (0) + !----- Native coordinates. ----------------------------------------------! + write(unit=20,fmt='(a,2(1x,i5),4(1x,a))') tmpvar,zlevmax(ng),99,tmpdesc & + ,'[',vpun(iv),']' + case default + !----- Other coordinates. -----------------------------------------------! + write(unit=20,fmt='(a,2(1x,i5),4(1x,a))') tmpvar,inplevs,99,tmpdesc & + ,'[',vpun(iv),']' + end select + !---------------------------------------------------------------------------! + end do + !------------------------------------------------------------------------------! + + case (7) + !------------------------------------------------------------------------------! + ! 3-D variable. Make one entry per patch. ! + !------------------------------------------------------------------------------! + do ip = 1, iep_np + write(patchnumber,fmt='(i2.2)') ip + tmpvar = trim(vp(iv))//patchnumber + tmpdesc = trim(vpln(iv))//': Patch # '//patchnumber + write(unit=20,fmt='(a,2(1x,i5),4(1x,a))') tmpvar,0,99,tmpdesc & + ,'[',vpun(iv),']' + end do + !------------------------------------------------------------------------------! + + case (8) + !------------------------------------------------------------------------------! + ! 4-D variable. Make one entry per patch, with vertical being number of ! + ! soil layers. ! + !------------------------------------------------------------------------------! + do ip = 1, iep_np + write(patchnumber,fmt='(i2.2)') ip + tmpvar = trim(vp(iv))//patchnumber + tmpdesc = trim(vpln(iv))//': Patch # '//patchnumber + write(unit=20,fmt='(a,2(1x,i5),4(1x,a))') tmpvar,nzvp(iv),99,tmpdesc & + ,'[',vpun(iv),']' + end do + !------------------------------------------------------------------------------! + + case (9) + !------------------------------------------------------------------------------! + ! 3-D variable. Make one entry per cloud. ! + !------------------------------------------------------------------------------! + do ic = 1, iep_nc + write(cldnumber,fmt='(i2.2)') ic + tmpvar = trim(vp(iv))//cldnumber + tmpdesc = trim(vpln(iv))//': Cloud # '//cldnumber + write(unit=20,fmt='(a,2(1x,i5),4(1x,a))') tmpvar,0,99,tmpdesc & + ,'[',vpun(iv),']' + end do + !------------------------------------------------------------------------------! + + case (10) + !------------------------------------------------------------------------------! + ! 3-D variable, soil layers with no patch. ! + !------------------------------------------------------------------------------! + write(unit=20,fmt='(a,2(1x,i5),4(1x,a))') vp(iv),nzvp(iv),99,vpln(iv) & + ,'[',vpun(iv),']' + !------------------------------------------------------------------------------! + end select + !---------------------------------------------------------------------------------! + end do varoutloop + !------------------------------------------------------------------------------------! + write(unit=20,fmt='(a)') 'endvars' + close(unit=20,status='keep') + write (unit=*,fmt='(92a)' ) ('=',n=1,92) + write (unit=*,fmt='(a)' ) ' ' + !------------------------------------------------------------------------------------! + end do gridloop + !---------------------------------------------------------------------------------------! + + write(*,'(a)') ' ------ Ramspost execution ends ------' + stop end program ramspost !==========================================================================================! !==========================================================================================! @@ -618,8 +994,9 @@ end program ramspost !==========================================================================================! !==========================================================================================! -subroutine ep_getvar(cvar,rout,a,b,nx,ny,nz,ng,fn,cdname,cdunits,itype,npatch,nclouds,nzg & - ,a2,rout2,a6,rout6) +subroutine ep_getvar(cvar,nx,ny,nz,ng,fn,cdname,cdunits,itype,npatch,nclouds,nzg) + use rout_coms, only : rout & ! intent(inout) + , rout_vars ! ! variable type implicit none !----- Arguments. ----------------------------------------------------------------------! character(len=*) , intent(in) :: cvar @@ -634,34 +1011,31 @@ subroutine ep_getvar(cvar,rout,a,b,nx,ny,nz,ng,fn,cdname,cdunits,itype,npatch,nc integer , intent(in) :: npatch integer , intent(in) :: nzg integer , intent(in) :: nclouds - real , dimension(*) , intent(inout) :: a - real , dimension(*) , intent(inout) :: b - real , dimension(*) , intent(inout) :: a2 - real , dimension(*) , intent(inout) :: a6 - real , dimension(*) , intent(inout) :: rout - real , dimension(*) , intent(inout) :: rout2 - real , dimension(*) , intent(inout) :: rout6 !---------------------------------------------------------------------------------------! + !----- Load the variable. --------------------------------------------------------------! - call RAMS_varlib(cvar,nx,ny,nz,nzg,npatch,nclouds,ng,fn,cdname,cdunits,itype,a,b,a2,a6) + call RAMS_varlib(cvar,nx,ny,nz,nzg,npatch,nclouds,ng,fn,cdname,cdunits,itype & + ,rout(ng)%abuff,rout(ng)%bbuff) + !---------------------------------------------------------------------------------------! + !----- Copy to the appropriate scratch. ------------------------------------------------! select case (itype) case (2) - call atob(nx*ny,a,rout) + call atob(nx*ny,rout(ng)%abuff,rout(ng)%r2) case (3) - call atob(nx*ny*nz,a,rout) + call atob(nx*ny*nz,rout(ng)%abuff,rout(ng)%r3) case (6) - call atob(nx*ny*nzg*nclouds,a6,rout6) + call atob(nx*ny*nz*nclouds,rout(ng)%abuff,rout(ng)%r6) case (7) - call atob(nx*ny*npatch,a,rout) + call atob(nx*ny*npatch,rout(ng)%abuff,rout(ng)%r7) case (8) - call atob(nx*ny*nzg*npatch,a2,rout2) + call atob(nx*ny*nzg*npatch,rout(ng)%abuff,rout(ng)%r8) case (9) - call atob(nx*ny*nclouds,a,rout) + call atob(nx*ny*nclouds,rout(ng)%abuff,rout(ng)%r9) case (10) - call atob(nx*ny*nzg,a,rout) + call atob(nx*ny*nzg,rout(ng)%abuff,rout(ng)%r10) end select return end subroutine ep_getvar @@ -676,77 +1050,95 @@ end subroutine ep_getvar !==========================================================================================! !==========================================================================================! subroutine ep_setdate(iyear1,imonth1,idate1,strtim,itrec) - real time - - integer itrec(6) - itrec(1)=iyear1 - itrec(2)=imonth1 - itrec(3)=idate1 - itrec(4)=int(mod(strtim,24.)) - itrec(5)=int(mod(strtim,1.)*60) - itrec(6)=int(mod( (strtim) *3600.,60.)) + implicit none + !------ Arguments. ---------------------------------------------------------------------! + integer , intent(in) :: iyear1 + integer , intent(in) :: imonth1 + integer , intent(in) :: idate1 + real , intent(in) :: strtim + integer, dimension(6), intent(out) :: itrec + !---------------------------------------------------------------------------------------! - ! print*,'---------------------------------------' - ! print*,itrec(1),itrec(2),itrec(3),itrec(4),itrec(5), - ! + itrec(6) - ! print*,'---------------------------------------' + itrec(1) = iyear1 + itrec(2) = imonth1 + itrec(3) = idate1 + itrec(4) = int(mod(strtim,24.)) + itrec(5) = int(mod(strtim,1.)*60) + itrec(6) = int(mod( (strtim) *3600.,60.)) - return + return end subroutine ep_setdate +!==========================================================================================! +!==========================================================================================! -!***************************************************************************** - -! -------------------------------------------------------- -! - SUBROUTINE EP_PUTVAR : WRITE ARRAY TO GRADS FILE - -! -------------------------------------------------------- - -subroutine ep_putvar(rout,a,nx,ny,nxa,nxb,nya,nyb, & - nz,nrec,istartz,iendz) - dimension a(nx,ny),rout(nx,ny,nz) - integer istartz,iendz - ! - do k=istartz,iendz - do j=1,ny - do i=1,nx - a(i,j)=rout(i,j,k) - !cc - ! print*,'PUT VAR=',i,j,k,a(i,j) - !cc - enddo - enddo - nrec=nrec+1 - write (19,rec=nrec) ((a(i,j),i=nxa,nxb),j=nya,nyb) - ! write(19,rec=nrec) a - enddo - ! k=1 - ! write(18,'(59f10.3)')((rout(ii,jj,k),ii=1,nx),jj=1,ny) - ! - return + + + + +!==========================================================================================! +!==========================================================================================! +! This subroutine dumps the array to the output binary file (gra file). ! +!------------------------------------------------------------------------------------------! +subroutine ep_putvar(iunit,nxp,nyp,nzp,xa,xz,ya,yz,za,zz,array3d,irec) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: iunit + integer , intent(in) :: nxp + integer , intent(in) :: nyp + integer , intent(in) :: nzp + integer , intent(in) :: xa + integer , intent(in) :: xz + integer , intent(in) :: ya + integer , intent(in) :: yz + integer , intent(in) :: za + integer , intent(in) :: zz + real, dimension(nxp,nyp,nzp), intent(in) :: array3d + integer , intent(inout) :: irec + !----- Local variables. ----------------------------------------------------------------! + integer :: x + integer :: y + integer :: z + real, dimension(nxp,nyp) :: mat + !---------------------------------------------------------------------------------------! + do z=za,zz + do y=1,nyp + do x=1,nxp + mat(x,y) = array3d(x,y,z) + end do + end do + + irec=irec+1 + write (unit=iunit,rec=irec) ((mat(x,y),x=xa,xz),y=ya,yz) + end do + + return end subroutine ep_putvar +!==========================================================================================! +!==========================================================================================! !------------------------------------------------------------------- ! -Subroutine Matriz_interp(ng,nxg,nyg,nxr,nyr,rlat1,dlat, & +Subroutine array_interpol(ng,nxg,nyg,nxr,nyr,rlat1,dlat, & rlon1,dlon,iinf,jinf,rmi,proj) use rpost_coms + use rout_coms, only : undefflg use brams_data use misc_coms, only : glong, glatg Dimension rmi(nxg,nyg,4),iinf(nxg,nyg),jinf(nxg,nyg) character(len=*) :: proj ! - if(proj.ne.'YES'.AND.proj.ne.'yes') RETURN + if(trim(proj) == 'no') RETURN ! Construcao da matriz de interpolacao. ! Flag para pontos do grads fora do dominio do modelo - undef=-9.99e33 do i=1,nxg do j=1,nyg iinf(i,j)=1 jinf(i,j)=1 do l=1,4 - rmi(i,j,l)=undef + rmi(i,j,l)=undefflg enddo enddo enddo @@ -799,117 +1191,161 @@ Subroutine Matriz_interp(ng,nxg,nyg,nxr,nyr,rlat1,dlat, & enddo enddo return -end Subroutine Matriz_interp +end Subroutine array_interpol +!==========================================================================================! +!==========================================================================================! -!************************************************************************* -Subroutine proj_rams_to_grads(vp,n,nxr,nyr,nzz,nxg,nyg, & - rmi,iinf,jinf, & - rout,routgrads,rlat,rlon,proj) - character*(*) proj - character*10 vp - Dimension rlat(nxr,nyr),rlon(nxr,nyr) - Dimension rout(nxr,nyr,nzz),routgrads(nxg,nyg,nzz) - Dimension rmi(nxg,nyg,4),iinf(nxg,nyg),jinf(nxg,nyg) - if(proj.ne.'YES'.AND.proj.ne.'yes') then - if(nxg.ne.nxr.AND.nyg.ne.nyr) then - print*,'Projection with problems nxr nxg ...' - stop - endif - call rout_to_routgrads(nxr*nyr*nzz,rout,routgrads) - return - endif - do i=1,nxg - do j=1,nyg +!==========================================================================================! +!==========================================================================================! +subroutine proj_rams_to_grads(vp,n,nxr,nyr,nzz,nxg,nyg,rmi,iinf,jinf,this,thisgrads & + ,rlat,rlon,proj) + use rout_coms, only : maxnormal & ! intent(in) + , undefflg ! ! intent(in) + + implicit none + !----- Arguments. ----------------------------------------------------------------------! + character(len=*) , intent(in) :: vp + integer , intent(in) :: n + integer , intent(in) :: nxr + integer , intent(in) :: nyr + integer , intent(in) :: nzz + integer , intent(in) :: nxg + integer , intent(in) :: nyg + real , dimension(nxg,nyg,4) , intent(in) :: rmi + integer , dimension(nxg,nyg) , intent(in) :: iinf + integer , dimension(nxg,nyg) , intent(in) :: jinf + real , dimension(nxr,nyr,nzz), intent(in) :: this + real , dimension(nxg,nyg,nzz), intent(inout) :: thisgrads + real , dimension(nxr,nyr) , intent(in) :: rlat + real , dimension(nxr,nyr) , intent(in) :: rlon + character(len=*) , intent(in) :: proj + !----- Local variables. ----------------------------------------------------------------! + integer :: i + integer :: j + integer :: k + integer :: i1 + integer :: i2 + integer :: j1 + integer :: j2 + real :: r1 + real :: r2 + real :: r3 + real :: r4 + real :: rr1 + real :: rr2 + !---------------------------------------------------------------------------------------! - ! - ! print*,i,j,rmi(i,j,1),rmi(i,j,2),rmi(i,j,3),rmi(i,j,4) - ! - ! - r1= rmi(i,j,1) - r2= rmi(i,j,2) - r3= rmi(i,j,3) - r4= rmi(i,j,4) - i1= iinf(i,j) - i2= i1+1 - j1= jinf(i,j) - j2= j1+1 - - - do k=1,nzz - rr1= rout(i1,j1,k)*(1.-r1)+rout(i2,j1,k)*(1.-r2) - rr2= rout(i1,j2,k)*(1.-r1)+rout(i2,j2,k)*(1.-r2) - routgrads(i,j,k)=rr1*(1.-r3)+ rr2*(1.-r4) - - ! print*,rr1,rr2,rout(i1,j1,k),routgrads(i,j,k) - - if(abs(routgrads(i,j,k)).gt.1.E+06) & - routgrads(i,j,k)=-9.99E+33 - ! - !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - ! write(2,0998) - ! write(2,0999) i,j,i1,j1,glatg(j),glong(i) - ! write(2,1000) rlat(i1,j1),rlat(i2,j1),rlat(i1,j2),rlat(i2,j2) - ! write(2,1001) rlon(i1,j1),rlon(i2,j1),rlon(i1,j2),rlon(i2,j2) - ! write(2,1002) rout(i1,j1,k),rout(i2,j1,k),rout(i1,j2,k),& - ! rout(i2,j2,k), routgrads(i,j,k) - !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - enddo - enddo - enddo -0998 format(1x,'---------------------------------------------') -0999 format(1x,4i3,2f10.2) -1000 format(1x,4f10.2) -1001 format(1x,4f10.2) -1002 format(1x,4f10.2,f16.3) - - !xxxxxxxxxxxxxxxxxxxxxxxxx - ! k=1 - ! do jj=1,nyr - ! do ii=1,nxr - ! write(10,'(2i3,3f8.1)')ii,jj,rlat(ii,jj),rlon(ii,jj) - ! + ,rout(ii,jj,k) - ! enddo - ! enddo - ! do jj=1,nyg - ! do ii=1,nxg - ! write(11,'(2i3,3f8.1)')ii,jj,glatg(jj),glong(ii) - ! + ,routgrads(ii,jj,k) - ! enddo - ! enddo - !xxxxxxxxxxxxxxxxxxxxxxxxx - return -end Subroutine proj_rams_to_grads -!--------------------------------------------------------------------- -!--------------------------------------------------------------------- + !---------------------------------------------------------------------------------------! + ! Check whether to use lon-lat projection or not. ! + !---------------------------------------------------------------------------------------! + select case(trim(proj)) + case ('no') + !----- Ensure that the grads domain is exactly the same as the RAMS one. ------------! + if (nxg /= nxr .or. nyg /= nyr) then + call abort_run ('Projection with problems...','proj_rams_to_grads' & + ,'rpost_main.f90') + end if + call atob(nxr*nyr*nzz,this,thisgrads) + !------------------------------------------------------------------------------------! + + case default + + do i=1,nxg + do j=1,nyg + r1 = rmi(i,j,1) + r2 = rmi(i,j,2) + r3 = rmi(i,j,3) + r4 = rmi(i,j,4) + i1 = iinf(i,j) + i2 = i1+1 + j1 = jinf(i,j) + j2 = j1+1 + + + do k=1,nzz + rr1 = this(i1,j1,k) * (1. - r1) + this(i2,j1,k) * (1. - r2) + rr2 = this(i1,j2,k) * (1. - r1) + this(i2,j2,k) * (1. - r2) + thisgrads(i,j,k) = rr1 * (1. - r3) + rr2 * (1. - r4) + end do + end do + end do + + where (abs(thisgrads) > maxnormal) + thisgrads = undefflg + end where + + end select + return +end subroutine proj_rams_to_grads +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! subroutine ge_to_xy(polelat,polelon,xlon,xlat,x,y) + use rconstants, only : erad & ! intent(in) + , pio180 ! ! intent(in) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + real, intent(in) :: polelat + real, intent(in) :: polelon + real, intent(in) :: xlon + real, intent(in) :: xlat + real, intent(out) :: x + real, intent(out) :: y + !----- Local variables. ----------------------------------------------------------------! + real :: b + real :: f + real :: xlonrad + real :: xlatrad + real :: plonrad + real :: platrad + !---------------------------------------------------------------------------------------! - parameter(rt=6367000.00) - p=3.14159265360/180.00 - ! transformacao horizontal: - b = 1.0+sin(p*xlat)*sin(p*polelat)+ & - cos(p*xlat)*cos(p*polelat)*cos(p*(xlon-polelon)) + !----- Convert coordinates to radians. -------------------------------------------------! + xlonrad = pio180 * xlon + xlatrad = pio180 * xlat + plonrad = pio180 * polelon + platrad = pio180 * polelat + !---------------------------------------------------------------------------------------! - f = 2.00*rt/b + !----- Horizontal transform. -----------------------------------------------------------! + b = 1.0 + sin(xlatrad)*sin(platrad) + cos(platrad)*cos(platrad)*cos(xlonrad- plonrad) + !---------------------------------------------------------------------------------------! - y = f*(cos(p*polelat)*sin(p*xlat) - & - sin(p*polelat)*cos(p*xlat)*cos(p*(xlon-polelon))) + f = 2.00 * erad /b - x = f*(cos(p*xlat)*sin(p*(xlon - polelon))) - return + y = f * (cos(platrad)*sin(xlatrad) - sin(platrad)*cos(xlatrad)*cos(xlonrad-plonrad)) + + x = f * (cos(xlatrad)*sin(xlonrad - plonrad)) + + return end subroutine ge_to_xy +!==========================================================================================! +!==========================================================================================! + + + -!--------------------------------------------------------------------- + +!==========================================================================================! +!==========================================================================================! Subroutine geo_grid(nx,ny,rlat,rlon,dep_glon1,dep_glon2, & dep_glat1,dep_glat2, & rlatmin,rlatmax,rlonmin,rlonmax, & @@ -956,11 +1392,11 @@ Subroutine geo_grid(nx,ny,rlat,rlon,dep_glon1,dep_glon2, & dep_glat1= x/nx dep_glat2=xx/nx - if(proj.ne.'YES'.and.proj.ne.'yes') then + if(proj == 'no') then nxg=nx nyg=ny - else + elseif (proj == 'yes') then !...... Grade para o GRADS: @@ -1000,6 +1436,9 @@ Subroutine geo_grid(nx,ny,rlat,rlon,dep_glon1,dep_glon2, & ! print*,rlonmin,rlonmax,rlatmin,rlatmax ! print*,nxg,nyg,dep_glon2,dep_glat2,dep_glat1,dep_glon1 ! stop + else + call abort_run ('Invalid value for iproj: '//trim(proj)//'...' & + ,'geo_grid','rpost_main.f90') endif @@ -1019,15 +1458,3 @@ Subroutine geo_grid(nx,ny,rlat,rlon,dep_glon1,dep_glon2, & return end Subroutine geo_grid - -!--------------------------------------------------------------------- -subroutine rout_to_routgrads(nxyz,rinp,rout) - dimension rinp(nxyz),rout(nxyz) - do i=1,nxyz - rout(i)=rinp(i) - enddo - return -end subroutine rout_to_routgrads - -!--------------------------------------------------------------------- - diff --git a/Ramspost/src/driver/rpost_misc.f90 b/Ramspost/src/driver/rpost_misc.f90 index b0ea335fb..d83a9d926 100644 --- a/Ramspost/src/driver/rpost_misc.f90 +++ b/Ramspost/src/driver/rpost_misc.f90 @@ -1,53 +1,108 @@ +!==========================================================================================! +!==========================================================================================! +! This sub-routine extracts a 3-D array from a 4-D variable. ! +!------------------------------------------------------------------------------------------! +subroutine s4d_to_3d(xmax,ymax,zmax,emax,e,four,three) + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: xmax + integer , intent(in) :: ymax + integer , intent(in) :: zmax + integer , intent(in) :: emax + integer , intent(in) :: e + real , dimension(xmax,ymax,zmax,emax), intent(in) :: four + real , dimension(xmax,ymax,zmax) , intent(out) :: three + !----- Local variables. ----------------------------------------------------------------! + integer :: x + integer :: y + integer :: z + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! Extract the three dimensional array. ! + !---------------------------------------------------------------------------------------! + do z=1,zmax + do y=1,ymax + do x=1,xmax + three(x,y,z) = four(x,y,z,e) + end do + end do + end do + return +end subroutine s4d_to_3d +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +subroutine ctransvar(nx,ny,nz,a3d,topo,nzlev,izlev,zt,ztop) + use rpost_dims + use rout_coms , only : undefflg + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: nx + integer , intent(in) :: ny + integer , intent(in) :: nz + integer , intent(in) :: nzlev + real , intent(in) :: ztop + real , dimension(nx,ny,nz), intent(inout) :: a3d + real , dimension(nx,ny ), intent(in) :: topo + real , dimension(nzpmax ), intent(in) :: zt + real , dimension(nplmax ), intent(in) :: izlev + !----- Local variables. ----------------------------------------------------------------! + real , dimension(nzpmax,4) :: tmpvar + integer :: i + integer :: j + integer :: k + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! These are the levels for which we interpolate. ! + !---------------------------------------------------------------------------------------! + do k=1,nzlev + tmpvar(k,4) = izlev(k) + end do + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! Run the interpolation for all grid points. ! + !---------------------------------------------------------------------------------------! + do j=1,ny + do i=1,nx + do k=1,nz + tmpvar(k,1) = a3d(i,j,k) + tmpvar(k,2) = topo(i,j) + zt(k) * (1. - topo(i,j) / ztop) + end do + call htint(nz,tmpvar(:,1),tmpvar(:,2),nzlev,tmpvar(:,3),tmpvar(:,4)) + + do k=1,nzlev + if (tmpvar(k,4) < topo(i,j)) then + a3d (i,j,k) = undefflg + else + a3d (i,j,k) = tmpvar(k,3) + end if + end do + end do + end do + + return +end subroutine ctransvar +!==========================================================================================! +!==========================================================================================! + + - Subroutine S4d_to_3d(nxr,nyr,nzz,n5,ipatch,rout,rout2) - Dimension rout(nxr,nyr,nzz),rout2(nxr,nyr,nzz,n5) - do j=1,nyr - do i=1,nxr - do k=1,nzz - rout(i,j,k)=rout2(i,j,k,ipatch) - enddo - enddo - enddo - return - end -!--------------------------------------------------------------------- -!------------------------------------------------------------------- - subroutine Ctransvar(n1,n2,n3,a,topo,nzlev,izlev,zt,ztop) - use rpost_dims - dimension a(n1,n2,n3),topo(n1,n2),zt(n3) - real b(nzpmax,4) - integer izlev(nzpmax) - - do k=1,nzlev -! niveis onde serao interpolados os valores - b(k,4)=float(izlev(k)) - enddo - - do j=1,n2 - do i=1,n1 - do k=1,n3 - b(k,1)=a(i,j,k) - b(k,2)=topo(i,j)+zt(k)*(1.-topo(i,j)/ztop) -! if(i.eq.50.and.j.eq.50) print*,i,j,k,topo(i,j),zt(k), & -! b(k,1),b(k,2) - enddo - call htint(n3,b(1,1),b(1,2),nzlev,b(1,3),b(1,4)) - do k=1,nzlev - if( b(k,4).lt.topo(i,j)) then - a(i,j,k)= -9.99e33 -! print*,i,j,b(k,4),topo(i,j) -! stop - else - a(i,j,k)=b(k,3) - endif -! if(i.eq.50.and.j.eq.50) print*,b(k,3) - enddo - enddo - enddo - - return - end !==========================================================================================! @@ -212,75 +267,121 @@ subroutine define_grid2(nx,ny,loni,lonf,lati,latf,nxg,nyg,& return end -! --------------------------------------------------------------- -! - SUBROUTINE PTRANSVAR : LOAD RAMS VARIABLE FROM ANALYSIS - -! --------------------------------------------------------------- - - subroutine ptransvar(a,nx,ny,nz,nplev,iplev,pi,zlev,zplev,topo) - use rpost_dims - real b(nzpmax,4) - real a(nx,ny,nz),topo(nx,ny),pi(nx,ny,nz), & - zlev(*),zplev(nx,ny,20) - integer nx,ny,nz,nplev,iplev(20) +!==========================================================================================! +!==========================================================================================! +! Subroutine ptransvar. This subroutine interpolates the 3-d variable to the sought ! +! pressure levels. ! +!------------------------------------------------------------------------------------------! +subroutine ptransvar(a3d,nx,ny,nz,nplev,iplev,exner,zlev,zplev,topo) + use rpost_dims + use therm_lib , only: press2exner ! ! function + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: nx + integer , intent(in) :: ny + integer , intent(in) :: nz + integer , intent(in) :: nplev + real , dimension(nplmax) , intent(in) :: iplev + real , dimension(nx,ny,nz) , intent(inout) :: a3d + real , dimension(nx,ny) , intent(in) :: topo + real , dimension(nx,ny,nz) , intent(in) :: exner + real , dimension(nx,ny,nplev), intent(inout) :: zplev + real , dimension(nzpmax) , intent(inout) :: zlev + !----- Local variables. ----------------------------------------------------------------! + real , dimension(nzpmax,4) :: tmpvar + integer :: i + integer :: j + integer :: k + integer :: kk + !---------------------------------------------------------------------------------------! -! print*,nx,ny,nz,nplev,iplev + !----- Find the exner function equivalent for the pressure levels. ---------------------! + do k=1,nplev + tmpvar(nplev-k+1,4) = press2exner(100.*iplev(k)) + end do + !---------------------------------------------------------------------------------------! - do i=1,nplev - b(nplev-i+1,4)=1004.*(iplev(i)/1000.)**.286 - enddo - do j=1,ny - do i=1,nx - do k=1,nz + !---------------------------------------------------------------------------------------! + ! Interpolate the variable. ! + !---------------------------------------------------------------------------------------! + do j=1,ny + do i=1,nx + do k=1,nz + kk = nz-k+1 + tmpvar(kk,1)=a3d (i,j,k) + tmpvar(kk,2)=exner(i,j,k) + end do + + call htint(nz,tmpvar(:,1),tmpvar(:,2),nplev,tmpvar(:,3),tmpvar(:,4)) + do k=1,nplev + a3d(i,j,nplev-k+1) = tmpvar(k,3) + end do + + do k=1,nz kk=nz-k+1 - b(kk,1)=a(i,j,k) - b(kk,2)=pi(i,j,k) - enddo - call htint(nz,b(1,1),b(1,2),nplev,b(1,3),b(1,4)) - do k=1,nplev -! print*,i,j,k,a(i,j,k),b(k,3),pi(i,j,k),b(k,4) - a(i,j,nplev-k+1)=b(k,3) + tmpvar(kk,1) = zlev(k)+topo(i,j) + tmpvar(kk,2) = exner(i,j,k) + end do + call htint(nz,tmpvar(:,1),tmpvar(:,2),nplev,tmpvar(:,3),tmpvar(:,4)) + do k=1,nplev + zplev(i,j,nplev-k+1) = tmpvar(k,3) + end do + end do + end do + return +end subroutine ptransvar +!==========================================================================================! +!==========================================================================================! - enddo - - do k=1,nz - kk=nz-k+1 - b(kk,1)=zlev(k)+topo(i,j) - b(kk,2)=pi(i,j,k) - enddo - call htint(nz,b(1,1),b(1,2),nplev,b(1,3),b(1,4)) - do k=1,nplev - zplev(i,j,nplev-k+1)=b(k,3) - enddo - enddo - enddo - - return - end -!*************************************************************************** - -!*************************************************************************** -!*************************************************************************** - -!-------------------------------------------------- - subroutine select_sigmaz(n1,n2,n3,a,nzlev,izlev) - use rpost_dims - dimension a(n1,n2,n3) - real b(nzpmax,4) - integer izlev(nzpmax) - - do k=1,nzlev - do j=1,n2 - do i=1,n1 - a(i,j,k)=a(i,j,izlev(k)) - enddo - enddo - enddo + + + + + +!==========================================================================================! +!==========================================================================================! +! This subroutine selects the sought sigma-z levels. ! +!------------------------------------------------------------------------------------------! +subroutine select_sigmaz(nx,ny,nz,a3d,nzlev,zlev) + use rpost_dims + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: nx + integer , intent(in) :: ny + integer , intent(in) :: nz + integer , intent(in) :: nzlev + real , dimension(nx,ny,nz), intent(inout) :: a3d + real , dimension(nzlev) , intent(in) :: zlev + !----- Local variables. ----------------------------------------------------------------! + integer :: i + integer :: j + integer :: k + integer :: ilev + !---------------------------------------------------------------------------------------! + + do k=1,nzlev + ilev = nint(zlev(k)) + do j=1,ny + do i=1,nx + a3d(i,j,k) = a3d(i,j,ilev) + end do + end do + end do - return - end -!------------------------------------------------------------------- + return +end subroutine select_sigmaz +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! subroutine date1(ib,iy,im,id) iy=int(ib/10000) im=int( (ib-iy*10000)/100 ) diff --git a/Ramspost/src/driver/variables.f90 b/Ramspost/src/driver/variables.f90 index c11aa639e..787992ffb 100644 --- a/Ramspost/src/driver/variables.f90 +++ b/Ramspost/src/driver/variables.f90 @@ -11,11 +11,12 @@ subroutine RAMS_anal_init(nfile,fnames,file_prefix,dep_zlev,iep_nx,iep_ny,iep_nz use rconstants, only : day_sec & ! intent(in) , hr_sec & ! intent(in) , min_sec ! ! intent(in) - + use somevars + implicit none !----- Arguments. ----------------------------------------------------------------------! integer , intent(out) :: nfile - character(len=str_len), dimension(maxfiles) , intent(in) :: fnames + character(len=str_len), dimension(maxfiles) , intent(inout) :: fnames real , dimension(nzpmax,maxgrds), intent(inout) :: dep_zlev integer , intent(inout) :: iep_np integer , intent(inout) :: iep_nc @@ -114,15 +115,19 @@ subroutine RAMS_anal_init(nfile,fnames,file_prefix,dep_zlev,iep_nx,iep_ny,iep_nz if (nfn == 1) then iep_ngrids=ngrids do n=1,ngrids - maxmem = max(maxmem,nnxp(n)*nnyp(n)*max(nnzp(n),npatch*nzg,nnzp(n)*nclouds)) - iep_nx(n) = nnxp(n) - iep_ny(n) = nnyp(n) - iep_nz(n) = nnzp(n) + nnxp(n) = mynnxp(n) + nnyp(n) = mynnyp(n) + nnzp(n) = mynnzp(n) + maxmem = max(maxmem, mynnxp(n)*mynnyp(n) & + * max(mynnzp(n),npatch*nzg,mynnzp(n)*nclouds)) + iep_nx(n) = mynnxp(n) + iep_ny(n) = mynnyp(n) + iep_nz(n) = mynnzp(n) iep_ng = nzg iep_np = npatch iep_nc = nclouds - do nn=1,nnzp(n) - dep_zlev(nn,n)=ztn(nn,n) + do nn=1,mynnzp(n) + dep_zlev(nn,n)=myztn(nn,n) end do end do end if @@ -165,19 +170,19 @@ subroutine RAMS_anal_init(nfile,fnames,file_prefix,dep_zlev,iep_nx,iep_ny,iep_nz nfgrids(nfn) = ngrids do ng=1,ngrids - nfgpnts(1,ng,nfn) = nnxp(ng) - nfgpnts(2,ng,nfn) = nnyp(ng) - nfgpnts(3,ng,nfn) = nnzp(ng) + nfgpnts(1,ng,nfn) = mynnxp(ng) + nfgpnts(2,ng,nfn) = mynnyp(ng) + nfgpnts(3,ng,nfn) = mynnzp(ng) nfgpnts(4,ng,nfn) = nzg fdelx(ng,nfn) = DELTAXN(NG) fdely(ng,nfn) = DELTAYN(NG) - do k=1,nnzp(ng) - flevels(k,ng,nfn) = ztn(k,ng) + do k=1,mynnzp(ng) + flevels(k,ng,nfn) = myztn(k,ng) end do end do - httop = zmn(nnzp(1)-1,1) + httop = myzmn(mynnzp(1)-1,1) close(unit=10,status='keep') @@ -200,9 +205,12 @@ end subroutine RAMS_anal_init !==========================================================================================! subroutine RAMS_get_time_init(nfl,iyear,imonth,idate,ihour,imin) use brams_data, only : iftimes ! ! intent(in) - use rpost_coms, only : iyear1 & ! intent(in) - , imonth1 & ! intent(in) - , idate1 ! ! intent(in) + use somevars , only : myiyear1 & ! intent(in) + , myimonth1 & ! intent(in) + , myidate1 ! ! intent(in) + use rpost_coms, only : iyear1 & ! intent(in) + , imonth1 & ! intent(in) + , idate1 ! ! intent(in) implicit none !----- Arguments. ----------------------------------------------------------------------! integer, intent(in) :: nfl @@ -213,11 +221,14 @@ subroutine RAMS_get_time_init(nfl,iyear,imonth,idate,ihour,imin) integer, intent(out) :: imin !---------------------------------------------------------------------------------------! - iyear =iyear1 - imonth=imonth1 - idate =idate1 - ihour =int(float(iftimes(nfl))/10000.) - imin =int(float(iftimes(nfl)-10000*ihour)/100.) + iyear1 = myiyear1 + imonth1 = myimonth1 + idate1 = myidate1 + iyear = myiyear1 + imonth = myimonth1 + idate = myidate1 + ihour = int(float(iftimes(nfl))/10000.) + imin = int(float(iftimes(nfl)-10000*ihour)/100.) return end subroutine RAMS_get_time_init !==========================================================================================! @@ -381,9 +392,10 @@ end function RAMS_getvar !==========================================================================================! !==========================================================================================! subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar_type & - ,a,b,a2,a6) + ,a,b) use rconstants use rpost_coms + use rout_coms , only : undefflg ! ! intent(in) use rpost_dims, only : nwave ! ! intent(in) use leaf_coms , only : ustmin & ! intent(in) , ubmin ! ! intent(in) @@ -410,8 +422,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar character(len=*) , intent(out) :: cdunits real , dimension(*), intent(inout) :: a real , dimension(*), intent(inout) :: b - real , dimension(*), intent(inout) :: a2 - real , dimension(*), intent(inout) :: a6 !----- Local variables. ----------------------------------------------------------------! integer :: idim_type integer :: irecind @@ -933,53 +943,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar cdname='ice mixing ratio' cdunits='g/kg' - case ('total_cond') - ivar_type=3 - call RAMS_comp_zero(nx,ny,nz,a) - ierr= RAMS_getvar('RCP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - ierr= RAMS_getvar('RRP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - ierr= RAMS_getvar('RPP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - ierr= RAMS_getvar('RSP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - ierr= RAMS_getvar('RAP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - ierr= RAMS_getvar('RGP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - ierr= RAMS_getvar('RHP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - - call RAMS_comp_mults(nx,ny,nz,a,1.e3) - call RAMS_comp_noneg(nx,ny,nz,a) - cdname='cloud mixing ratio' - cdunits='g/kg' - - case ('rall') - ivar_type=3 - ierr= RAMS_getvar('RV',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - ierr= RAMS_getvar('RCP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - ierr= RAMS_getvar('RRP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - ierr= RAMS_getvar('RPP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - ierr= RAMS_getvar('RSP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - ierr= RAMS_getvar('RAP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - ierr= RAMS_getvar('RGP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - ierr= RAMS_getvar('RHP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - - call RAMS_comp_mults(nx,ny,nz,a,1.e3) - call RAMS_comp_noneg(nx,ny,nz,a) - cdname='vapour + condensed mixing ratio' - cdunits='g/kg' - case ('rtp') ivar_type=3 ierr= RAMS_getvar('RTP',idim_type,ngrd,a,b,flnm) @@ -1032,23 +995,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar cdname='relative humidity' cdunits='pct' - case ('clear_frac') - ivar_type=2 - ierr= RAMS_getvar('RV',idim_type,ngrd,b,a,flnm) - ierr_getvar = ierr_getvar + ierr - ierr= RAMS_getvar('PI',idim_type,ngrd,scr%c,a,flnm) - ierr_getvar = ierr_getvar + ierr - ierr= RAMS_getvar('THETA',idim_type,ngrd,scr%d,a,flnm) - ierr_getvar = ierr_getvar + ierr - - call RAMS_comp_rh(nx,ny,nz,b,scr%c,scr%d) - call RAMS_comp_noneg(nx,ny,nz,b) - - call cldfraction(nx,ny,nz,a,scr%c,b) - - cdname='clear sky fraction' - cdunits='n/d' - case ('cloud_concen_mg') ivar_type=3 ! variable 18 is iccp @@ -1295,27 +1241,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar cdname='hail diam' cdunits='mm' - case ('q2','qrain') - ivar_type=3 - ierr= RAMS_getvar('Q2',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='Rain internal energy' - cdunits='J/kg' - - case ('q6','qgraupel') - ivar_type=3 - ierr= RAMS_getvar('Q6',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='Graupel internal energy' - cdunits='J/kg' - - case ('q7','qhail') - ivar_type=3 - ierr= RAMS_getvar('Q7',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='Hail internal energy' - cdunits='J/kg' - case ('rain_temp') ivar_type=3 ierr= RAMS_getvar('Q2',idim_type,ngrd,a,b,flnm) @@ -1340,51 +1265,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar cdname='hail temperature' cdunits='C' - case ('rain_air_tempdif') - ivar_type=3 - ierr= RAMS_getvar('Q2',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_raintemp(nx,ny,nz,a) - ierr= RAMS_getvar('THETA',idim_type,ngrd,scr%d,b,flnm) - ierr_getvar = ierr_getvar + ierr - ierr= RAMS_getvar('PI',idim_type,ngrd,scr%c,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_tempK(nx,ny,nz,scr%d,scr%c) - call RAMS_comp_tempC(nx,ny,nz,1,scr%d) - call RAMS_comp_subt(nx,ny,nz,a,scr%d) - cdname='rain-air temp' - cdunits='K' - - case ('graup_air_tempdf') - ivar_type=3 - ierr= RAMS_getvar('Q6',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_qtcpcp(nx,ny,nz,a) - ierr= RAMS_getvar('THETA',idim_type,ngrd,scr%d,b,flnm) - ierr_getvar = ierr_getvar + ierr - ierr= RAMS_getvar('PI',idim_type,ngrd,scr%c,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_tempK(nx,ny,nz,scr%d,scr%c) - call RAMS_comp_tempC(nx,ny,nz,1,scr%d) - call RAMS_comp_subt(nx,ny,nz,a,scr%d) - cdname='graupel-air temp' - cdunits='K' - - case ('hail_air_tempdif') - ivar_type=3 - ierr= RAMS_getvar('Q7',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_qtcpcp(nx,ny,nz,a) - ierr= RAMS_getvar('THETA',idim_type,ngrd,scr%d,b,flnm) - ierr_getvar = ierr_getvar + ierr - ierr= RAMS_getvar('PI',idim_type,ngrd,scr%c,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_tempK(nx,ny,nz,scr%d,scr%c) - call RAMS_comp_tempC(nx,ny,nz,1,scr%d) - call RAMS_comp_subt(nx,ny,nz,a,scr%d) - cdname='hail-air temp' - cdunits='K' - case ('graup_fracliq') ivar_type=3 ierr= RAMS_getvar('Q6',idim_type,ngrd,a,b,flnm) @@ -1422,7 +1302,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar ierr= RAMS_getvar('THSRC',idim_type,ngrd,a,b,flnm) ierr_getvar = ierr_getvar + ierr call RAMS_comp_mults(nx,ny,nz*ncld,a,86400.) - call get_cumulus(nx,ny,nz,ncld,a,a6) cdname='deep conv heat rate' cdunits='K/day' @@ -1432,10 +1311,22 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar ierr_getvar = ierr_getvar + ierr call RAMS_comp_mults(nx,ny,nz*ncld,a,86400.) call RAMS_comp_mults(nx,ny,nz*ncld,a,1000.) - call get_cumulus(nx,ny,nz,ncld,a,a6) cdname='deep conv moist rate' cdunits='g/kg/day' + case ('co2src') + ivar_type=6 + if (co2_on) then + ierr= RAMS_getvar('CO2SRC',idim_type,ngrd,a,b,flnm) + ierr_getvar = ierr_getvar + ierr + call RAMS_comp_mults(nx,ny,nz*ncld,a,86400.) + else + write (unit=*,fmt='(a,1x,es12.5)') ' # Assigning zero CO2SRC =',co2con(1) + call ae0(nx*ny*nz*ncld,a,0.) + end if + cdname='deep conv co2 rate' + cdunits='umol/mol/day' + case ('fthrd') ivar_type=3 ierr= RAMS_getvar('FTHRD',idim_type,ngrd,a,b,flnm) @@ -1466,53 +1357,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar cdname='vert diffusion coeff' cdunits='m2/s' - case ('accpr','liqpcp') - ivar_type=2 - ierr= RAMS_getvar('ACCPR',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - select case (trim(cvar)) - case ('accpr') - cdname='accum rain' - case('liqpcp') - cdname='purely liquid precip' - end select - cdunits='kg/m2' - - case ('accpp') - ivar_type=2 - ierr= RAMS_getvar('ACCPP',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='accum pristine' - cdunits='kg/m2' - - case ('accps') - ivar_type=2 - ierr= RAMS_getvar('ACCPS',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='accum snow' - cdunits='kg/m2' - - case ('accpa') - ivar_type=2 - ierr= RAMS_getvar('ACCPA',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='accum aggregates' - cdunits='kg/m2' - - case ('accpg') - ivar_type=2 - ierr= RAMS_getvar('ACCPG',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='accum graupel' - cdunits='kg/m2' - - case ('accph') - ivar_type=2 - ierr= RAMS_getvar('ACCPH',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='accum hail' - cdunits='kg/m2' - case ('totpcp','totpcp_in','precip','precip_in') ivar_type=2 call RAMS_comp_zero(nx,ny,1,a) @@ -1573,53 +1417,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar cdunits='kg/m2' call RAMS_comp_noneg(nx,ny,1,a) - case ('pcprr') - ivar_type=2 - ierr= RAMS_getvar('PCPRR',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_mults(nx,ny,1,a,3600.) - cdname='rain precip rate' - cdunits='mm/hr liq equiv' - - case ('pcprp') - ivar_type=2 - ierr= RAMS_getvar('PCPRP',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_mults(nx,ny,1,a,3600.) - cdname='pristine precip rate' - cdunits='mm/hr liq equiv' - - case ('psprs') - ivar_type=2 - ierr= RAMS_getvar('PCPRS',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_mults(nx,ny,1,a,3600.) - cdname='snow precip rate' - cdunits='mm/hr liq equiv' - - case ('pcpra') - ivar_type=2 - ierr= RAMS_getvar('PCPRA',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_mults(nx,ny,1,a,3600.) - cdname='aggregates precip rate' - cdunits='mm/hr liq equiv' - - case ('pcprg') - ivar_type=2 - ierr= RAMS_getvar('PCPRG',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='graupel precip rate' - cdunits='mm/hr liq equiv' - - case ('pcprh') - ivar_type=2 - ierr= RAMS_getvar('PCPRH',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_mults(nx,ny,1,a,3600.) - cdname='hail precip rate' - cdunits='mm/hr liq equiv' - case ('pcpg') ivar_type=2 ierr= RAMS_getvar('PCPG',idim_type,ngrd,a,b,flnm) @@ -1672,8 +1469,8 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar ivar_type=9 ierr= RAMS_getvar('CONPRR',idim_type,ngrd,a,b,flnm) ierr_getvar = ierr_getvar + ierr - call RAMS_comp_mults(nx,ny,1,a,3600.) - call RAMS_comp_noneg(nx,ny,1,a) + call RAMS_comp_mults(nx,ny,ncld,a,3600.) + call RAMS_comp_noneg(nx,ny,ncld,a) cdname='convective pcp rate' cdunits='mm/hr' @@ -1685,9 +1482,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar cdname='accum convective pcp' cdunits='mm' - - - case ('cape') ivar_type=2 !- rel hum (e) @@ -1711,7 +1505,7 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar ierr_getvar = ierr_getvar + ierr call RAMS_comp_press(nx,ny,nz,scr%c) !- cape - call cape_cine(nx,ny,nz,scr%c,scr%d,scr%e,a,'cape',-9.99e33) + call cape_cine(nx,ny,nz,scr%c,scr%d,scr%e,a,'cape',undefflg) cdname='cape' cdunits='J/kg' @@ -1739,7 +1533,7 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar ierr_getvar = ierr_getvar + ierr call RAMS_comp_press(nx,ny,nz,scr%c) !- cape - call cape_cine(nx,ny,nz,scr%c,scr%d,scr%e,a,'cine',-9.99e33) + call cape_cine(nx,ny,nz,scr%c,scr%d,scr%e,a,'cine',undefflg) cdname='cine' cdunits='J/kg' @@ -1783,87 +1577,11 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar cdunits='hPa' !ML] - - ![Marcos Parâmetros da convecção para uso em STILT - - case ('cfxup_deep') - ivar_type=3 - ierr= RAMS_getvar('CFXUP1',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - ! call RAMS_comp_noneg(nx,ny,nz,a) - cdname='Conv. upward flux - deep' - cdunits='kg/m2/s' - - case ('cfxdn_deep') - ivar_type=3 - ierr= RAMS_getvar('CFXDnx',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - ! call RAMS_comp_nopos(nx,ny,nz,a) - cdname='Conv. downward flux - deep' - cdunits='kg/m2/s' - - case ('cfxup_shal') - ivar_type=3 - ierr= RAMS_getvar('CFXUP2',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - ! call RAMS_comp_noneg(nx,ny,nz,a) - cdname='Conv. upward flux - shallow' - cdunits='kg/m2/s' - - case ('efxup_deep') - ivar_type=3 - ierr= RAMS_getvar('EFXUP1',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - ! call RAMS_comp_noneg(nx,ny,nz,a) - cdname='Updraft entrainment flux - deep' - cdunits='kg/m2/s' - - case ('efxdn_deep') - ivar_type=3 - ierr= RAMS_getvar('EFXDnx',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - ! call RAMS_comp_noneg(nx,ny,nz,a) - cdname='Downdraft entrainment flux - deep' - cdunits='kg/m2/s' - - case ('efxup_shal') - ivar_type=3 - ierr= RAMS_getvar('EFXUP2',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - ! call RAMS_comp_noneg(nx,ny,nz,a) - cdname='Updraft entrainment flux - shallow' - cdunits='kg/m2/s' - - case ('dfxup_deep') - ivar_type=3 - ierr= RAMS_getvar('DFXUP1',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - ! call RAMS_comp_noneg(nx,ny,nz,a) - cdname='Updraft detrainment flux - deep' - cdunits='kg/m2/s' - - case ('dfxdn_deep') - ivar_type=3 - ierr= RAMS_getvar('DFXDnx',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - ! call RAMS_comp_noneg(nx,ny,nz,a) - cdname='Downdraft detrainment flux - deep' - cdunits='kg/m2/s' - - case ('dfxup_shal') - ivar_type=3 - ierr= RAMS_getvar('DFXUP2',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - ! call RAMS_comp_noneg(nx,ny,nz,a) - cdname='Updraft detrainment flux - shallow' - cdunits='kg/m2/s' - case ('cfxup') ivar_type=6 ierr= RAMS_getvar('CFXUP',idim_type,ngrd,a,b,flnm) ierr_getvar = ierr_getvar + ierr call RAMS_comp_noneg(nx,ny,nz*ncld,a) - call get_cumulus(nx,ny,nz,ncld,a,a6) cdname='Convective upward flux' cdunits='kg/m2/s' @@ -1872,7 +1590,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar ierr= RAMS_getvar('CFXDN',idim_type,ngrd,a,b,flnm) ierr_getvar = ierr_getvar + ierr call RAMS_comp_nopos(nx,ny,nz*ncld,a) - call get_cumulus(nx,ny,nz,ncld,a,a6) cdname='Convective downward flux' cdunits='kg/m2/s' @@ -1881,7 +1598,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar ierr= RAMS_getvar('DFXUP',idim_type,ngrd,a,b,flnm) ierr_getvar = ierr_getvar + ierr call RAMS_comp_noneg(nx,ny,nz*ncld,a) - call get_cumulus(nx,ny,nz,ncld,a,a6) cdname='Detrainment upward flux' cdunits='kg/m2/s' @@ -1890,7 +1606,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar ierr= RAMS_getvar('DFXDN',idim_type,ngrd,a,b,flnm) ierr_getvar = ierr_getvar + ierr call RAMS_comp_noneg(nx,ny,nz*ncld,a) - call get_cumulus(nx,ny,nz,ncld,a,a6) cdname='Detrainment upward flux' cdunits='kg/m2/s' @@ -1899,7 +1614,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar ierr= RAMS_getvar('EFXUP',idim_type,ngrd,a,b,flnm) ierr_getvar = ierr_getvar + ierr call RAMS_comp_noneg(nx,ny,nz*ncld,a) - call get_cumulus(nx,ny,nz,ncld,a,a6) cdname='Entrainment upward flux' cdunits='kg/m2/s' @@ -1908,7 +1622,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar ierr= RAMS_getvar('EFXDN',idim_type,ngrd,a,b,flnm) ierr_getvar = ierr_getvar + ierr call RAMS_comp_noneg(nx,ny,nz*ncld,a) - call get_cumulus(nx,ny,nz,ncld,a,a6) cdname='Entrainment upward flux' cdunits='kg/m2/s' @@ -1959,91 +1672,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar cdname='Obukhov lenght scale' cdunits='m' - - ! Vertically-integrated atmospheric moisture - - case ('vertint_rt','vertint_cond') - ivar_type=2 - - ierr= RAMS_getvar('TOPT',idim_type,ngrd,scr%e,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_dn0(nx,ny,nz,scr%c,b,scr%d,scr%e,ngrd) - - select case(trim(cvar)) - case ('vertint_rt') - ierr= RAMS_getvar('RV',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='vertint total water' - case ('vertint_cond') - call RAMS_comp_zero(nx,ny,nz,a) - cdname='vertint condensate' - end select - - ierr= RAMS_getvar('RCP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - ierr= RAMS_getvar('RRP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - ierr= RAMS_getvar('RPP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - ierr= RAMS_getvar('RSP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - ierr= RAMS_getvar('RAP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - ierr= RAMS_getvar('RGP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - ierr= RAMS_getvar('RHP',idim_type,ngrd,scr%c,b,flnm) - if(ierr == 0) call RAMS_comp_accum(nx,ny,nz,a,scr%c) - - call RAMS_comp_mult(nx,ny,nz,a,scr%d) - call RAMS_comp_vertint(nx,ny,nz,a,scr%e,ngrd) - - cdunits='mm' - - - ! 2D SURFACE HEAT, MOISTURE, MOMENTUM AND RADIATIVE FLUXES - - case ('SFLUX_T') - ivar_type=2 - ierr= RAMS_getvar('SFLUX_T',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='SFLUX_T' - cdunits='m' - - case ('SFLUX_R') - ivar_type=2 - ierr= RAMS_getvar('SFLUX_R',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='SFLUX_R' - cdunits='m' - - case ('uw') - ivar_type=2 - ierr= RAMS_getvar('UW',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='uw' - cdunits='m' - - case ('vw') - ivar_type=2 - ierr= RAMS_getvar('VW',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='vw' - cdunits='m' - - case ('SFLUX_W') - ivar_type=2 - ierr= RAMS_getvar('SFLUX_W',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='SFLUX_W' - cdunits='m' - - case ('SFLUX_C') - ivar_type=2 - ierr= RAMS_getvar('SFLUX_C',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='SFLUX_C' - cdunits='m' - case ('hflxca') ivar_type=2 ierr= RAMS_getvar('SFLUX_T',idim_type,ngrd,a,b,flnm) @@ -2075,7 +1703,13 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar ierr= RAMS_getvar('TOPT',idim_type,ngrd,scr%e,b,flnm) call RAMS_comp_dn0(nx,ny,nz,b,scr%c,scr%d,scr%e,ngrd) call RAMS_comp_mult(nx,ny,1,a,scr%d) - call RAMS_comp_mults(nx,ny,1,a,alvl) + ierr = RAMS_getvar('CAN_THETA',idim_type,ngrd,scr%f,b,flnm) + ierr_getvar = ierr_getvar + ierr + ierr = RAMS_getvar('CAN_PRSS',idim_type,ngrd,scr%g,b,flnm) + ierr_getvar = ierr_getvar + ierr + call RAMS_comp_theta2temp(nx,ny,1,scr%f,scr%g) + call RAMS_comp_wflx2latent(nx,ny,1,a,scr%f) + cdname='water flux from canopy to atmosphere' cdunits='W/m2' @@ -2723,62 +2357,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar cdname='number of snow levels' cdunits='#' - case ('grnd_mixrat_p','grnd_mixrat_ps') - - irecind = 1 - irecsize = nnxp(ngrd) * nnyp(ngrd) * npat - select case (trim(cvar)) - case ('grnd_mixrat_ps') - ierr = RAMS_getvar('PATCH_AREA',idim_type,ngrd & - ,a(irecind),b,flnm) - ierr_getvar = ierr_getvar + ierr - end select - - irecind = irecind + irecsize - ierr = RAMS_getvar('SFC_RS',idim_type,ngrd & - ,a(irecind),b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_mults(nx,ny,npat,a(irecind),1.e3) - - select case (trim(cvar)) - case ('grnd_mixrat_p') - ivar_type = 7 - case ('grnd_mixrat_ps') - ivar_type = 2 - call RAMS_comp_patchsum_l(nnxp(ngrd),nnyp(ngrd),1,npat,a) - end select - - cdname='ground mixing ratio' - cdunits='g/kg' - - case ('soil_mixrat_p','soil_mixrat_ps') - - irecind = 1 - irecsize = nnxp(ngrd) * nnyp(ngrd) * npat - select case (trim(cvar)) - case ('soil_mixrat_ps') - ierr = RAMS_getvar('PATCH_AREA',idim_type,ngrd & - ,a(irecind),b,flnm) - ierr_getvar = ierr_getvar + ierr - end select - - irecind = irecind + irecsize - ierr = RAMS_getvar('SOIL_RS',idim_type,ngrd & - ,a(irecind),b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_mults(nx,ny,npat,a(irecind),1.e3) - - select case (trim(cvar)) - case ('soil_mixrat_p') - ivar_type = 7 - case ('soil_mixrat_ps') - ivar_type = 2 - call RAMS_comp_patchsum_l(nnxp(ngrd),nnyp(ngrd),1,npat,a) - end select - - cdname='soil mixing ratio' - cdunits='g/kg' - case ('lwater_p','lwater_ps') irecind = 1 @@ -3434,34 +3012,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar cdname='soil textural class' cdunits='#' - case ('soilq','soilq_ps') - - irecind = 1 - - select case (trim(cvar)) - case ('soilq_ps') - irecsize = nnxp(ngrd) * nnyp(ngrd) * npat - ierr = RAMS_getvar('PATCH_AREA',idim_type,ngrd & - ,a(irecind),b,flnm) - irecind = irecind + irecsize - end select - ierr = RAMS_getvar('SOIL_ENERGY',idim_type,ngrd & - ,a(irecind),b,flnm) - ierr_getvar = ierr_getvar + ierr - - call get_leaf_soil(nx,ny,nsl,npat,a(irecind),a2) - - select case (trim(cvar)) - case ('soilq') - ivar_type = 8 - case ('soilq_ps') - ivar_type = 10 - call RAMS_comp_patchsum_l(nnxp(ngrd),nnyp(ngrd),nsl,npat,a) - end select - - cdname='soil q' - cdunits='J/m3' - case ('smoist','smoist_ps') irecind = 1 @@ -3479,7 +3029,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar select case (trim(cvar)) case ('smoist') ivar_type = 8 - call get_leaf_soil(nx,ny,nsl,npat,a,a2) case ('smoist_ps') ivar_type = 10 call RAMS_comp_patchsum_l(nnxp(ngrd),nnyp(ngrd),nsl,npat,a) @@ -3511,13 +3060,12 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar call RAMS_comp_copysst(nx,ny,nsl,a(irecind)) - call RAMS_comp_qwtk(nx,ny,nsl,npat,a(irecind),scr%c,scr%d) + call RAMS_comp_uextcm2tl(nx,ny,nsl,npat,a(irecind),scr%c,scr%d) select case (trim(cvar)) case ('tsoil') call RAMS_comp_tempC(nx,ny,nsl,npat,a) - call get_leaf_soil(nx,ny,nsl,npat,a,a2) ivar_type = 8 case ('tsoil_ps') ivar_type = 10 @@ -3551,7 +3099,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar select case (trim(cvar)) case ('smfrac') ivar_type = 8 - call get_leaf_soil(nx,ny,nsl,npat,a,a2) case ('smfrac_ps') ivar_type = 10 call RAMS_comp_patchsum_l(nnxp(ngrd),nnyp(ngrd),nsl,npat,a) @@ -3603,338 +3150,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar cdname='Pond/snow depth' cdunits='m' - ! CATT - - case ('CO') - ivar_type=3 - ierr= RAMS_getvar('SCLP001',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_noneg(nx,ny,nz,a) - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/kg para kg/kg - call RAMS_transf_ppb(nx,ny,nz,a) - cdname='CO Concentration' - cdunits='ppb' - - case ('src1') - ivar_type=3 - ierr= RAMS_getvar('scrsc001',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/day para kg/day - cdname='emission 1' - cdunits='kg/m2/day' - - case ('src2') - ivar_type=3 - ierr= RAMS_getvar('scrsc002',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/day para kg/day - cdname='emission 2' - cdunits='kg/m2/day' - - case ('src3') - ivar_type=3 - ierr= RAMS_getvar('scrsc003',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/day para kg/day - cdname='emission 3' - cdunits='kg/m2/day' - - case ('src4') - ivar_type=3 - ierr= RAMS_getvar('scrsc004',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/day para kg/day - cdname='emission 4' - cdunits='kg/m2/day' - - case ('src5') - ivar_type=3 - ierr= RAMS_getvar('scrsc005',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/day para kg/day - cdname='emission 5' - cdunits='kg/m2/day' - - case ('src6') - ivar_type=3 - ierr= RAMS_getvar('scrsc006',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/day para kg/day - cdname='emission 6' - cdunits='kg/m2/day' - - case ('src7') - ivar_type=3 - ierr= RAMS_getvar('scrsc007',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/day para kg/day - cdname='emission 7' - cdunits='kg/m2/day' - - case ('src8') - ivar_type=3 - ierr= RAMS_getvar('scrsc008',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/day para kg/day - cdname='emission 5' - cdunits='kg/m2/day' - - case ('COstc') - ivar_type=3 - ierr= RAMS_getvar('SCLP002',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_noneg(nx,ny,nz,a) - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/kg para kg/kg - call RAMS_transf_ppb(nx,ny,nz,a) - cdname='CO Conc. without conv. transp' - cdunits='ppb' - - case ('COANT') - ivar_type=3 - ierr= RAMS_getvar('SCLP004',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_noneg(nx,ny,nz,a) - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/kg para kg/kg - call RAMS_transf_ppb(nx,ny,nz,a) - cdname='CO Concentration ANTRO' - cdunits='ppb' - - case ('COTOT') - ivar_type=3 - ierr= RAMS_getvar('SCLP005',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_noneg(nx,ny,nz,a) - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/kg para kg/kg - call RAMS_transf_ppb(nx,ny,nz,a) - cdname='CO Conc ANTRO+BB' - cdunits='ppb' - - case ('PM25') - ivar_type=3 - ierr= RAMS_getvar('SCLP003',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_noneg(nx,ny,nz,a) - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/kg para kg/kg - !air density - ierr= RAMS_getvar('TOPT',idim_type,ngrd,scr%e,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_dn0(nx,ny,nz,b,scr%c,scr%d,scr%e,ngrd) - - call RAMS_transf_ugm3(nx,ny,nz,a,scr%d) - call RAMS_comp_noneg(nx,ny,nz,a) - cdname='PM25 Concentration' - cdunits='ug/m3' - - - case ('PMINT') - ivar_type=2 - ierr= RAMS_getvar('SCLP003',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_noneg(nx,ny,nz,a) - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/kg para kg/kg - !air density - ierr= RAMS_getvar('TOPT',idim_type,ngrd,scr%e,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_dn0(nx,ny,nz,b,scr%c,scr%d,scr%e,ngrd) - call RAMS_comp_mult(nx,ny,nz,a,scr%d) !Unit: kg[pm25]/m3 - call RAMS_comp_vertint(nx,ny,nz,a,scr%e,ngrd) ! Unit: kg[pm25]/m2 - call RAMS_comp_mults(nx,ny,nz,a,1.e+9) ! converte de kg/m2 para ug/m2 - - cdname='PM25 vert int' - cdunits='ug/m2' - - ! ------------------ AOT ------------------ - ! WAVE / 0.256, 0.280, 0.296, 0.319, 0.335, 0.365, 0.420, 0.482, - ! 0.598, 0.690, 0.762, 0.719, 0.813, 0.862, 0.926, 1.005, - ! 1.111, 1.333, 1.562, 1.770, 2.051, 2.210, 2.584, 3.284, - ! 3.809, 4.292, - ! 4.546, 4.878, 5.128, 5.405, 5.714, 6.061, 6.452, 6.897, - ! 7.407, 8.333, 9.009, 10.309,12.500,13.889,16.667, - ! 20.000, 26.316, 35.714, 62.50 - case ('aot256') - ivar_type=2 - ierr= RAMS_getvar('AOT',idim_type,ngrd,scr%c,b,flnm) - ierr_getvar = ierr_getvar + ierr - call D3toD2(nx,ny,nwave,1,a,scr%c) - cdname='AOT 256nm' - cdunits=' ' - - case ('aot296') - ivar_type=2 - ierr= RAMS_getvar('AOT',idim_type,ngrd,scr%c,b,flnm) - ierr_getvar = ierr_getvar + ierr - call D3toD2(nx,ny,nwave,3,a,scr%c) - cdname='AOT 296nm' - cdunits=' ' - - case ('aot335') - ivar_type=2 - ierr= RAMS_getvar('AOT',idim_type,ngrd,scr%c,b,flnm) - ierr_getvar = ierr_getvar + ierr - call D3toD2(nx,ny,nwave,5,a,scr%c) - cdname='AOT 335nm' - cdunits=' ' - - case ('aot420') - ivar_type=2 - ierr= RAMS_getvar('AOT',idim_type,ngrd,scr%c,b,flnm) - ierr_getvar = ierr_getvar + ierr - call D3toD2(nx,ny,nwave,7,a,scr%c) - cdname='AOT 420nm' - cdunits=' ' - - case ('aot482') - ivar_type=2 - ierr= RAMS_getvar('AOT',idim_type,ngrd,scr%c,b,flnm) - ierr_getvar = ierr_getvar + ierr - call D3toD2(nx,ny,nwave,8,a,scr%c) - cdname='AOT 482nm' - cdunits=' ' - - - case ('aot598') - ivar_type=2 - ierr= RAMS_getvar('AOT',idim_type,ngrd,scr%c,b,flnm) - ierr_getvar = ierr_getvar + ierr - call D3toD2(nx,ny,nwave,9,a,scr%c) - cdname='AOT 598nm' - cdunits=' ' - - case ('aot690') - ivar_type=2 - ierr= RAMS_getvar('AOT',idim_type,ngrd,scr%c,b,flnm) - ierr_getvar = ierr_getvar + ierr - call D3toD2(nx,ny,nwave,10,a,scr%c) - cdname='AOT 690nm' - cdunits=' ' - - case ('aot500') - ivar_type=2 - ierr= RAMS_getvar('AOT',idim_type,ngrd,scr%c,b,flnm) - ierr_getvar = ierr_getvar + ierr - call D3toD2(nx,ny,nwave,11,a,scr%c) - cdname='AOT 500nm' - cdunits=' ' - - case ('aot550') - ivar_type=2 - ierr= RAMS_getvar('AOT',idim_type,ngrd,scr%c,b,flnm) - ierr_getvar = ierr_getvar + ierr - call D3toD2(nx,ny,nwave,12,a,scr%c) - cdname='AOT 550nm' - cdunits=' ' - - - case ('secog') - ivar_type=2 - ierr= RAMS_getvar('DUM1',idim_type,ngrd,scr%c,b,flnm) - ierr_getvar = ierr_getvar + ierr - call D3toD2(nx,ny,nz,2,a,scr%c) - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/day para kg/day - cdname='GOES-8 ABBA CO emission' - cdunits='kg/m2/day' - - - case ('secod') - ivar_type=2 - ierr= RAMS_getvar('DUM1',idim_type,ngrd,scr%c,b,flnm) - ierr_getvar = ierr_getvar + ierr - call D3toD2(nx,ny,nz,11,a,scr%c) - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/day para kg/day - cdname='Duncan CO emission' - cdunits='kg/m2/day' - - case ('secoant') - ivar_type=2 - ierr= RAMS_getvar('DUM1',idim_type,ngrd,scr%c,b,flnm) - ierr_getvar = ierr_getvar + ierr - call D3toD2(nx,ny,nz,11,a,scr%c) - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/day para kg/day - cdname='Antropogenic CO emission' - cdunits='kg/m2/day' - - case ('secoe') - ivar_type=2 - ierr= RAMS_getvar('DUM1',idim_type,ngrd,scr%c,b,flnm) - ierr_getvar = ierr_getvar + ierr - call D3toD2(nx,ny,nz,14,a,scr%c) - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/day para kg/day - cdname='EDGAR CO emission' - cdunits='kg/m2/day' - - - case ('scco') - ivar_type=2 - ierr= RAMS_getvar('QSC1',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='Massa de CO emitida' - cdunits='kg/(m2 day)' - - case ('scpm25') - ivar_type=2 - ierr= RAMS_getvar('QSC2',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='Massa de PM25 emitida' - cdunits='kg/(m2 day)' - - case ('sccofe') - ivar_type=2 - ierr= RAMS_getvar('QSC3',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='Massa de CO FWB - EDGAR emitida' - cdunits='kg/(m2 day)' - - case ('sccoae') - ivar_type=2 - ierr= RAMS_getvar('QSC4',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='Massa de CO AWB - EDGAR emitida' - cdunits='kg/(m2 day)' - - case ('sccobbe') - ivar_type=2 - ierr= RAMS_getvar('QSC5',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='Massa de CO BB - EDGAR emitida' - cdunits='kg/(m2 day)' - - case ('sccod') - ivar_type=2 - ierr= RAMS_getvar('QSC9',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='Massa de CO Duncan emitida' - cdunits='kg/(m2 day)' - - case ('sccol') - ivar_type=2 - ierr= RAMS_getvar('QSC3',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='Massa de CO emitida -logan' - cdunits='kg/(m2 day)' - - case ('sccoant') - ivar_type=2 - ierr= RAMS_getvar('QSC9',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='Massa de CO emitida -ANTROPO' - cdunits='kg/(m2 day)' - - case ('pw','pwv') - ivar_type=2 - ierr= RAMS_getvar('RV',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - !air density - ierr= RAMS_getvar('TOPT',idim_type,ngrd,scr%e,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_dn0(nx,ny,nz,b,scr%c,scr%d,scr%e,ngrd) ! d=dens_ar - call RAMS_comp_mult(nx,ny,nz,a,scr%d) ! aqui a=rv*dens_ar - call RAMS_comp_vertint(nx,ny,nz,a,scr%e,ngrd) ! agua em kg/m^2 - call RAMS_comp_mults(nx,ny,nz,a,0.1) !converte para cm = 1 kg/m^2 * 100 cm/m / (1000 kg/m^3 dens_agua) - cdname='precipitable water vapor' - cdunits='cm' - - - ! ------------------------ Stilt-RAMS coupling------------ case ('afxu') ivar_type=3 @@ -3985,49 +3200,10 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar cdname='averaged sigma W' cdunits='m/s' - case ('tlb') - ivar_type=3 - ierr= RAMS_getvar('TLB',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='averaged Lagr timescale' - cdunits='s' - - case ('tl') - ivar_type=3 - ierr= RAMS_getvar('TL',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - cdname='Lagr timescale' - cdunits='s' - - case ('tkeb') - ivar_type=3 - ierr= RAMS_getvar('TKEPB',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_noneg(nx,ny,nz,a) - cdname='average turb kinetic energy' - cdunits='m2/s2' - !------------Grell cumulus scheme -------------------------- - case ('wdm1') - ivar_type=2 - ierr= RAMS_getvar('wetdep001',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/kg para kg/kg - cdname='Wet deposition mass tracer 1' - cdunits='kg/m2' - - - case ('wdm3') - ivar_type=2 - ierr= RAMS_getvar('wetdep003',idim_type,ngrd,a,b,flnm) - ierr_getvar = ierr_getvar + ierr - call RAMS_comp_mults(nx,ny,nz,a,1.e-6) ! converte de mg/kg para kg/kg - cdname='Wet deposition mass tracer 3' - cdunits='kg/m2' - case ('cuprliq') ivar_type=6 @@ -4035,7 +3211,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar ierr_getvar = ierr_getvar + ierr call RAMS_comp_noneg(nx,ny,nz*ncld,a) call RAMS_comp_mults(nx,ny,nz*ncld,a,1000.) - call get_cumulus(nx,ny,nz,ncld,a,a6) cdname='Conv. water mixing ratio' cdunits='g/kg' @@ -4045,7 +3220,6 @@ subroutine RAMS_varlib(cvar,nx,ny,nz,nsl,npat,ncld,ngrd,flnm,cdname,cdunits,ivar ierr_getvar = ierr_getvar + ierr call RAMS_comp_noneg(nx,ny,nz*ncld,a) call RAMS_comp_mults(nx,ny,nz*ncld,a,1000.) - call get_cumulus(nx,ny,nz,ncld,a,a6) cdname='Conv. water mixing ratio' cdunits='g/kg' diff --git a/Ramspost/src/lib/comp_lib.f90 b/Ramspost/src/lib/comp_lib.f90 index 2bbe705f5..f9570c36a 100644 --- a/Ramspost/src/lib/comp_lib.f90 +++ b/Ramspost/src/lib/comp_lib.f90 @@ -16,7 +16,15 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) use somevars use rconstants use rpost_coms -use therm_lib, only : qtk, dewfrostpoint, rslif, virtt, thetaeiv +use rout_coms, only : undefflg +use therm_lib, only : uint2tl & ! function + , dewfrostpoint & ! function + , rslif & ! function + , virtt & ! function + , thetaeiv & ! function + , rehuil & ! function + , exner2press & ! function + , extheta2temp ! ! function dimension a(n1,n2,n3),b(n1,n2,n3),c(n1,n2,n3),d(n1,n2,n3),e(n1,n2,n3),o(n1,n2,n3),topt(n1,n2) dimension a2(n1,n2,n4,n5),a6(n1,n2,n3,n6) @@ -80,7 +88,7 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) do i=1,n1 do j=1,n2 - a(i,j,1) = (ztn(2,ngrd)+ ztn(1,ngrd)) + a(i,j,1) = (myztn(2,ngrd)+ myztn(1,ngrd)) enddo enddo @@ -91,7 +99,7 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) ! print*,k,c(i,j,k),ztn(k,ngrd) if(c(i,j,k).lt.tkemin) then kzi = k - a(i,j,1)=0.5*(ztn(kzi,ngrd)+ ztn(kzi-1,ngrd)) + a(i,j,1)=0.5*(myztn(kzi,ngrd)+ myztn(kzi-1,ngrd)) go to 500 endif enddo @@ -111,7 +119,7 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) rnebu=0. rodzint=0 do k=2,n3-1 - dz=(ztn(k,ngrd)-ztn(k-1,ngrd))*(1.-e(i,j,1)/zmn(nnzp(1)-1,1)) + dz=(myztn(k,ngrd)-myztn(k-1,ngrd))*(1.-e(i,j,1)/myzmn(mynnzp(1)-1,1)) rnebu = rnebu + b(i,j,k)*c(i,j,k)*dz rodzint = rodzint + c(i,j,k)*dz enddo @@ -195,7 +203,7 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) do j=1,n2 do i=1,n1 a(i,j,1)=c(i,j,1) -! if(a(i,j,1) .lt. 0.0001) a(i,j,1) = -9.99e33 +! if(a(i,j,1) .lt. 0.0001) a(i,j,1) = undefflg ! print*,i,j,klevel,c(i,j,klevel) enddo enddo @@ -350,7 +358,7 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) do j=1,n2 do i=1,n1 a(i,j,k)=c(i,j,1) & - +ztn(k,ngrd)*(1.-c(i,j,1)/zmn(nnzp(1)-1,1)) + +myztn(k,ngrd)*(1.-c(i,j,1)/myzmn(mynnzp(1)-1,1)) enddo enddo enddo @@ -375,7 +383,7 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) do k=1,n3 do j=1,n2 do i=1,n1 - a(i,j,k)=a(i,j,k)*b(i,j,k)/cp + a(i,j,k)=a(i,j,k)*b(i,j,k)/cpdry enddo enddo enddo @@ -385,7 +393,7 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) do k=1,n3 do j=1,n2 do i=1,n1 - a(i,j,k)=(a(i,j,k)/cp)**cpor*p00*.01 + a(i,j,k)=exner2press(a(i,j,k)) * .01 enddo enddo enddo @@ -434,7 +442,7 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) entry RAMS_comp_sfcdiv(n1,n2,n3,a,ngrd) do j=1,n2 do i=1,n1 - a(i,j,1)=-(a(i,j,2)-a(i,j,1))*dztn(2,ngrd) + a(i,j,1)=-(a(i,j,2)-a(i,j,1))*mydztn(2,ngrd) enddo enddo return @@ -489,8 +497,8 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) do k=1,n3 do j=1,n2 do i=1,n1 - xpress=(b(i,j,k)/cp)**cpor*p00 - xtemp=c(i,j,k)*b(i,j,k)/cp + xpress=exner2press(b(i,j,k)) + xtemp=extheta2temp(b(i,j,k),c(i,j,k)) xwatsat=rslif(xpress,xtemp) a(i,j,k)=dewfrostpoint(xpress,min(a(i,j,k),xwatsat) ) enddo @@ -505,26 +513,11 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) do i=1,n1 TL=55.+1./( 1./(f1(i,j,k)-55.) - & log(f2(i,j,k)/100.)/2840.) - a(i,j,k)=a(i,j,k)*exp((alvl*e(i,j,k))/(cp*TL)) + a(i,j,k)=a(i,j,k)*exp((alvl3*e(i,j,k))/(cpdry*TL)) enddo enddo enddo return - -!entry RAMS_comp_thete(n1,n2,n3,a,b,c) -! do k=1,n3 -! do j=1,n2 -! do i=1,n1 -! xpress=(b(i,j,k)/cp)**cpor*p00 -! xtemp=c(i,j,k)*b(i,j,k)/cp -! xwatsat=rslif(xpress,xtemp) -! a(i,j,k)=c(i,j,k)*exp( alvl*xwatsat & -! /(cp*dewfrostpoint(xpress,min(a(i,j,k),xwatsat) )) ) -! enddo -! enddo -! enddo -!return - !Demerval> entry RAMS_comp_thetv(n1,n2,n3,a,b,c) @@ -551,22 +544,9 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) do k=1,n3 do j=1,n2 do i=1,n1 - xtemp=c(i,j,k)*b(i,j,k)/cp - xpress=(b(i,j,k)/cp)**cpor*p00 - a(i,j,k)=100.*min(1. & - ,max(0.,a(i,j,k)/rslif(xpress,xtemp))) - enddo - enddo - enddo -return - -entry RAMS_comp_watsat(n1,n2,n3,a,b,c) - do k=1,n3 - do j=1,n2 - do i=1,n1 - c(i,j,k)=c(i,j,k)*a(i,j,k)/cp - b(i,j,k)=(b(i,j,k)/cp)**cpor*p00 - a(i,j,k)=rslif(b(i,j,k),c(i,j,k)) + xtemp = extheta2temp(b(i,j,k),c(i,j,k)) + xpress = exner2press(b(i,j,k)) + a(i,j,k) = 100. * min(1.,rehuil(xpress,xtemp,a(i,j,k),.false.)) enddo enddo enddo @@ -584,31 +564,20 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) do k=2,n3 do j=1,n2 do i=1,n1 - a(i,j,k)=-(a(i,j,k)-a(i,j,k-1))*dztn(k,ngrd) + a(i,j,k)=-(a(i,j,k)-a(i,j,k-1))*mydztn(k,ngrd) enddo enddo enddo return entry RAMS_comp_vertint(n1,n2,n3,a,topt,ngrd) - ztop = zmn(nnzp(1)-1,1) + ztop = myzmn(mynnzp(1)-1,1) do j = 1,n2 do i = 1,n1 rtgt = 1. - topt(i,j) / ztop a(i,j,1) = 0. do k = 2,n3-1 - a(i,j,1) = a(i,j,1) + a(i,j,k) * (zmn(k,ngrd)-zmn(k-1,ngrd)) * rtgt - enddo - enddo - enddo -return - -entry RAMS_comp_ppress(n1,n2,n3,a,c) - do k=1,n3 - do j=1,n2 - do i=1,n1 - a(i,j,k) = 1000. * (a(i,j,k)/cp) ** cpor & - - 1000. * (c(i,j,k)/cp) ** cpor + a(i,j,1) = a(i,j,1) + a(i,j,k) * (myzmn(k,ngrd)-myzmn(k-1,ngrd)) * rtgt enddo enddo enddo @@ -619,9 +588,9 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) do j=1,n2 do i=1,n1 if (a(i,j,k) > 0.) then - a(i,j,k) = tsupercool + a(i,j,k) * cliqi - t00 + a(i,j,k) = tsupercool_liq + a(i,j,k) * cliqi - t00 else - a(i,j,k) = -9.99e33 + a(i,j,k) = undefflg end if enddo enddo @@ -633,10 +602,10 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) do j=1,n2 do i=1,n1 if (a(i,j,k) > 0.) then - call qtk(a(i,j,k),temptemp,fracliq) + call uint2tl(a(i,j,k),temptemp,fracliq) a(i,j,k) = temptemp - t00 else - a(i,j,k) = -9.99e33 + a(i,j,k) = undefflg end if end do end do @@ -647,7 +616,7 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) do k=1,n3 do j=1,n2 do i=1,n1 - call qtk(a(i,j,k),temptemp,fracliq) + call uint2tl(a(i,j,k),temptemp,fracliq) a(i,j,k) = fracliq end do end do @@ -658,7 +627,7 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) do k=1,n3 do j=1,n2 do i=1,n1 - call qtk(a(i,j,k),temptemp,fracliq) + call uint2tl(a(i,j,k),temptemp,fracliq) a(i,j,k) = 1.0 - fracliq enddo enddo @@ -693,7 +662,7 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) entry rams_fill_sst(n1,n2,n3,kp,a,c) do j=1,n2 do i = 1,n1 - call qtk(c(i,j,kp),temptemp,fracliq) + call uint2tl(c(i,j,kp),temptemp,fracliq) a(i,j,1) = temptemp-t00 enddo enddo @@ -721,10 +690,10 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) do i=1,n1 do j=1,n2 malhakz: do k=3,n3 - dtheta = (c(i,j,k)-c(i,j,k-1))/(ztn(k,ngrd)-ztn(k-1,ngrd)) + dtheta = (c(i,j,k)-c(i,j,k-1))/(myztn(k,ngrd)-myztn(k-1,ngrd)) if (dtheta.gt.estratosfera) exit malhakz end do malhakz - a(i,j,1)=0.5*(ztn(k,ngrd)+ztn(k-1,ngrd)) + a(i,j,1)=0.5*(myztn(k,ngrd)+myztn(k-1,ngrd)) end do end do return @@ -735,7 +704,7 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) do i=1,n1 do j=1,n2 malhakt: do k=3,n3 - dtheta = (c(i,j,k)-c(i,j,k-1))/(ztn(k,ngrd)-ztn(k-1,ngrd)) + dtheta = (c(i,j,k)-c(i,j,k-1))/(myztn(k,ngrd)-myztn(k-1,ngrd)) if (dtheta.gt.estratosfera) exit malhakt end do malhakt a(i,j,1)=0.5*(e(i,j,k)+e(i,j,k-1)) @@ -749,7 +718,7 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) do i=1,n1 do j=1,n2 malhakp: do k=3,n3 - dtheta = (c(i,j,k)-c(i,j,k-1))/(ztn(k,ngrd)-ztn(k-1,ngrd)) + dtheta = (c(i,j,k)-c(i,j,k-1))/(myztn(k,ngrd)-myztn(k-1,ngrd)) if (dtheta.gt.estratosfera) exit malhakp end do malhakp a(i,j,1)=exp(0.5*(log(e(i,j,k))+log(e(i,j,k-1)))) @@ -777,11 +746,11 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) kzi = k if(abs(e(i,j,k)).gt.1.e-5) then - a(i,j,1) =0.5*(ztn(kzi,ngrd)+ ztn(kzi-1,ngrd)) + a(i,j,1) =0.5*(myztn(kzi,ngrd)+ myztn(kzi-1,ngrd)) else - a(i,j,1) =0.5*(ztn(kzi,ngrd)+ ztn(kzi-1,ngrd)) + a(i,j,1) =0.5*(myztn(kzi,ngrd)+ myztn(kzi-1,ngrd)) endif if(a(i,j,1).lt.0..or.kzi.le.2) a(i,j,1)=0. @@ -807,7 +776,7 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) do i=1,n1 pblht=0. do k=2,n3 - pblht=ztn(k,ngrd)*(1.-c(i,j,1)/zmn(nnzp(1)-1,1)) + pblht=myztn(k,ngrd)*(1.-c(i,j,1)/myzmn(mynnzp(1)-1,1)) !DSM if(a(i,j,k).le.tkethrsh) goto 10 enddo 10 continue @@ -819,24 +788,6 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) return -entry RAMS_comp_etrans(n1,n2,n3,a,b,a2d) - do j=1,n2 - do i=1,n1 - temp1=a(i,j,1)*b(i,j,1)/cp - press1=(b(i,j,1)/cp)**cpor*p00 - dens=press1/(rgas*temp1) - if(i.eq.5.and.j.eq.5) then - print*,'============++++++' - print*,temp1,press1,dens,a2d(i,j) - endif - a(i,j,1)=a2d(i,j)*dens*1.e-3*39.37*3600. - do k=2,n3 - a(i,j,k)=a(i,j,1) - enddo - enddo - enddo -return - entry RAMS_comp_slpress(n1,n2,n3,theta,pp,z,slp) ! ! This subroutine calculates the pressure at level zlev. it @@ -868,7 +819,7 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) thbar=.5*(theta(i,j,kbot)+theta(i,j,ktop)) endif slp(i,j)=pp(i,j,kbot)-ddz*sl_g/thbar - slp(i,j)=(slp(i,j) * cpi)**cpor*p00 + slp(i,j)=(slp(i,j) * cpdryi)**cpor*p00 end do end do return @@ -881,7 +832,7 @@ subroutine RAMS_comp(n1,n2,n3,n4,n5,n6) if(a(i,j,k).ge.0.0001.and.b(i,j,k).ge.0.99)kmax=k enddo if(kmax.gt.2)then - a(i,j,1)=ztn(kmax,ngrd) + a(i,j,1)=myztn(kmax,ngrd) else a(i,j,1)=0.0 endif @@ -942,20 +893,35 @@ end subroutine get_leaf_soil !==========================================================================================! !==========================================================================================! +! This sub-routine converts a 3-D array into a cloud-dependent, 4-D array. ! +!------------------------------------------------------------------------------------------! subroutine get_cumulus(n1,n2,n3,n6,a,a6) implicit none - integer, intent(in) :: n1,n2,n3,n6 + !------ Arguments. ---------------------------------------------------------------------! + integer , intent(in) :: n1 + integer , intent(in) :: n2 + integer , intent(in) :: n3 + integer , intent(in) :: n6 real, dimension(n1,n2,n3,n6), intent(out) :: a6 - real, dimension(n1,n2,n3*n6), intent(in) :: a - integer :: kip, k,i,j,ip + real, dimension(n1,n2,n3*n6), intent(in) :: a + !----- Local variables. ----------------------------------------------------------------! + integer :: kic + integer :: k + integer :: i + integer :: j + integer :: ic + !---------------------------------------------------------------------------------------! - kip=0 - do ip=1,n6 + + !---------------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------------! + kic=0 + do ic=1,n6 do k=1,n3 - kip=kip+1 + kic=kic+1 do j=1,n2 do i=1,n1 - a6(i,j,k,ip)=a(i,j,kip) + a6(i,j,k,ic)=a(i,j,kic) end do end do end do @@ -976,7 +942,7 @@ subroutine RAMS_comp_richardson(n1,n2,n3,np,rib,z0,speed,thetav_atm,thetav_can,t use somevars use rconstants - use therm_lib, only : qtk, qwtk, dewfrostpoint, rslif, virtt, thetaeiv + use therm_lib, only : uint2tl, uextcm2tl, dewfrostpoint, rslif, virtt, thetaeiv implicit none integer , intent(in) :: n1,n2,n3,np real , dimension(n1,n2,np), intent(inout) :: rib @@ -1014,7 +980,7 @@ subroutine RAMS_comp_dn0(n1,n2,n3,a,b,c,topt,ngrd) use somevars use rconstants - use therm_lib, only : qtk, qwtk, dewfrostpoint, rslif, virtt, thetaeiv + use therm_lib, only : uint2tl, uextcm2tl, dewfrostpoint, rslif, virtt, thetaeiv implicit none integer , intent(in) :: n1,n2,n3 real , dimension(n1,n2,n3), intent(inout) :: a,b,c @@ -1039,7 +1005,7 @@ subroutine RAMS_comp_dn0(n1,n2,n3,a,b,c,topt,ngrd) c1=grav*2.*(1.-topt(i,j)/zedtop) c2=(1-cpor) - c3=cp**c2 + c3=cpdry**c2 do k=n3-1,1,-1 a(i,j,k)=a(i,j,k+1) +c1/((b(i,j,k)+b(i,j,k+1))*mydzmn(k,ngrd)) enddo @@ -1065,7 +1031,7 @@ subroutine RAMS_comp_relvortx(n1,n2,n3,a,b,c,topt,ngrd) use somevars use rconstants - use therm_lib, only : qtk, qwtk, dewfrostpoint, rslif, virtt, thetaeiv + use therm_lib, only : uint2tl, uextcm2tl, dewfrostpoint, rslif, virtt, thetaeiv implicit none integer , intent(in) :: n1,n2,n3 real , dimension(n1,n2,n3), intent(inout) :: a,b,c @@ -1136,7 +1102,7 @@ subroutine RAMS_comp_relvorty(n1,n2,n3,a,b,c,topt,ngrd) use somevars use rconstants - use therm_lib, only : qtk, qwtk, dewfrostpoint, rslif, virtt, thetaeiv + use therm_lib, only : uint2tl, uextcm2tl, dewfrostpoint, rslif, virtt, thetaeiv implicit none integer , intent(in) :: n1,n2,n3 real , dimension(n1,n2,n3), intent(inout) :: a,b,c @@ -1210,7 +1176,7 @@ subroutine RAMS_comp_relvortz(n1,n2,n3,a,b,c,topt,ngrd) use somevars use rconstants - use therm_lib, only : qtk, qwtk, dewfrostpoint, rslif, virtt, thetaeiv + use therm_lib, only : uint2tl, uextcm2tl, dewfrostpoint, rslif, virtt, thetaeiv implicit none integer , intent(in) :: n1,n2,n3 real , dimension(n1,n2,n3), intent(inout) :: a,b,c @@ -1276,7 +1242,7 @@ subroutine RAMS_comp_totvortz(n1,n2,n3,a,b,c,topt,ngrd) use somevars use rconstants - use therm_lib, only : qtk, qwtk, dewfrostpoint, rslif, virtt, thetaeiv + use therm_lib, only : uint2tl, uextcm2tl, dewfrostpoint, rslif, virtt, thetaeiv implicit none integer , intent(in) :: n1,n2,n3 real , dimension(n1,n2,n3), intent(inout) :: a,b,c @@ -1351,7 +1317,7 @@ end subroutine RAMS_comp_totvortz subroutine RAMS_comp_potvortz(n1,n2,n3,a,b,c,e,topt,ngrd) use somevars use rconstants - use therm_lib, only : qtk, qwtk, dewfrostpoint, rslif, virtt, thetaeiv + use therm_lib, only : uint2tl, uextcm2tl, dewfrostpoint, rslif, virtt, thetaeiv implicit none integer , intent(in) :: n1,n2,n3 real , dimension(n1,n2,n3), intent(inout) :: a,b,c,e @@ -1566,13 +1532,13 @@ end subroutine RAMS_comp_solenoidy !==========================================================================================! subroutine RAMS_comp_sfcwmeantemp(n1,n2,ns,np,a,b,c,d,e) use rconstants - use therm_lib, only: qtk + use rout_coms, only : undefflg + use therm_lib, only: uint2tl implicit none integer :: n1,n2,ns,np,nlev,i,j,ip,k real, dimension(n1,n2,np) :: a,d,e real, dimension(n1,n2,ns,np) :: b,c real :: temptemp,fracliq,snowarea,xmasstot - real, parameter :: undef=-9.99e33 !a area !b energy !c mass @@ -1590,7 +1556,7 @@ subroutine RAMS_comp_sfcwmeantemp(n1,n2,ns,np,a,b,c,d,e) do k=1,nlev if (c(i,j,k,ip) > 1.e-6) then xmasstot = xmasstot + c(i,j,k,ip) - call qtk(b(i,j,k,ip),temptemp,fracliq) + call uint2tl(b(i,j,k,ip),temptemp,fracliq) e(i,j,ip) = e(i,j,ip) + temptemp*c(i,j,k,ip) end if end do @@ -1610,10 +1576,10 @@ subroutine RAMS_comp_sfcwmeantemp(n1,n2,ns,np,a,b,c,d,e) if (snowarea > 0.) then e(i,j,1) = e(i,j,1) / snowarea else - e(i,j,1) = undef + e(i,j,1) = undefflg end if else - e(i,j,1) = undef + e(i,j,1) = undefflg end if end do end do @@ -1641,7 +1607,7 @@ subroutine RAMS_comp_thetaeiv(n1,n2,n3,xxx,temp,pres,rv,rtp) do i=1,n1 if (rtp(i,j,k) < rv(i,j,k)) rtp(i,j,k) = rv(i,j,k) xxx(i,j,k)=thetaeiv(xxx(i,j,k),pres(i,j,k),temp(i,j,k),rv(i,j,k),rtp(i,j,k) & - ,12,.true.) + ,.true.) end do end do end do @@ -1658,11 +1624,11 @@ end subroutine RAMS_comp_thetaeiv !==========================================================================================! !==========================================================================================! subroutine RAMS_comp_sfcwinteg(n1,n2,ns,np,a,c,d,e) + use rout_coms, only : undefflg implicit none integer :: n1,n2,ns,np,nlev,i,j,ip,k real, dimension(n1,n2,np) :: a,d,e real, dimension(n1,n2,ns,np) :: c - real, parameter :: undef=-9.99e33 !a area !c mass/depth !d nlev @@ -1670,7 +1636,7 @@ subroutine RAMS_comp_sfcwinteg(n1,n2,ns,np,a,c,d,e) do j=1,n2 do i=1,n1 if (a(i,j,1) > 0.99) then - e(i,j,1) = -9.99e33 + e(i,j,1) = undefflg else e(i,j,1) = 0. do ip=2,np @@ -1781,6 +1747,7 @@ end subroutine RAMS_comp_patchsum !------------------------------------------------------------------------------------------! subroutine RAMS_comp_patchsum_l(nx,ny,nz,np,iovar) use leaf_coms, only : min_patch_area + use rout_coms, only : undefflg implicit none !----- Arguments. ----------------------------------------------------------------------! integer , intent(in) :: nx @@ -1839,7 +1806,7 @@ subroutine RAMS_comp_patchsum_l(nx,ny,nz,np,iovar) end do psum(x,y,z) = psum(x,y,z) / landarea else - psum(x,y,z) = -9.99e33 + psum(x,y,z) = undefflg end if end do end do @@ -1907,7 +1874,7 @@ end subroutine RAMS_comp_bigpatch !==========================================================================================! subroutine RAMS_comp_tvegc(n1,n2,n3,a,b,c,e) use rconstants, only : t00 - use therm_lib , only : qwtk + use therm_lib , only : uextcm2tl implicit none integer, intent(in) :: n1,n2,n3 real, dimension(n1,n2,n3), intent(in) :: c,e @@ -1929,7 +1896,7 @@ subroutine RAMS_comp_tvegc(n1,n2,n3,a,b,c,e) ! canopy temperature. !------------------------------------------------------------------------ if (c(i,j,k) > 10.) then - call qwtk(a(i,j,k),b(i,j,k),c(i,j,k),temptemp,fracliq) + call uextcm2tl(a(i,j,k),b(i,j,k),c(i,j,k),temptemp,fracliq) a(i,j,k) = temptemp-t00 b(i,j,k) = fracliq else @@ -2489,11 +2456,11 @@ end subroutine RAMS_flush_to_zero ! Ouput: SLP - sea-level pressure (hPa) 2D ! !------------------------------------------------------------------------------------------! subroutine RAMS_comp_slpmm5(n1,n2,n3,theta,pp,z,slp) - use rconstants, only : cp & ! intent(in) - , cpi & ! intent(in) - , rdry & ! intent(in) - , cpor & ! intent(in) - , p00 ! ! intent(in) + use rconstants, only : cpdryi & ! intent(in) + , rdry & ! intent(in) + , cpor & ! intent(in) + , p00 ! ! intent(in) + use therm_lib , only : exner2press ! ! function implicit none !----- Arguments. ----------------------------------------------------------------------! integer , intent(in) :: n1 @@ -2517,9 +2484,9 @@ subroutine RAMS_comp_slpmm5(n1,n2,n3,theta,pp,z,slp) do j = 1,n2 do i = 1,n1 !----- Calculate surface pressure. -----------------------------------------------! - sfp(i,j) = (0.5*(pp(i,j,1)+pp(i,j,2))/cp)**cpor*p00*.01 + sfp(i,j) = exner2press(0.5*(pp(i,j,1)+pp(i,j,2))) *.01 !----- Calculate surface temp. ---------------------------------------------------! - ts(i,j) = 0.5 * cpi * (theta(i,j,1)*pp(i,j,1) + theta(i,j,2)*pp(j,j,2)) + ts(i,j) = 0.5 * cpdryi * (theta(i,j,1)*pp(i,j,1) + theta(i,j,2)*pp(j,j,2)) end do end do @@ -2528,8 +2495,8 @@ subroutine RAMS_comp_slpmm5(n1,n2,n3,theta,pp,z,slp) do j = 1,n2 do i = 1,n1 !----- Flip arrays upside down for input to GRAPH subroutine. -----------------! - t_mm5(i,j,kk) = theta(i,j,k) * pp(i,j,k) * cpi - p_mm5(i,j,kk) = (pp(i,j,k) * cpi)**cpor * p00 * .01 + t_mm5(i,j,kk) = theta(i,j,k) * pp(i,j,k) * cpdryi + p_mm5(i,j,kk) = exner2press(pp(i,j,k)) * .01 end do end do end do @@ -2775,10 +2742,10 @@ end subroutine RAMS_comp_slmstf ! This subroutine computes the temperature and liquid fraction given the internal ! ! energy and water content. ! !------------------------------------------------------------------------------------------! -subroutine RAMS_comp_qwtk(nx,ny,nz,np,inqoutt,inwoutl,soil_text) +subroutine RAMS_comp_uextcm2tl(nx,ny,nz,np,inqoutt,inwoutl,soil_text) use rconstants, only : wdns ! ! intent(in) use soil_coms , only : soil ! ! intent(in) - use therm_lib , only : qwtk ! ! subroutine + use therm_lib , only : uextcm2tl ! ! subroutine !----- Arguments. ----------------------------------------------------------------------! integer , intent(in) :: nx integer , intent(in) :: ny @@ -2811,7 +2778,7 @@ subroutine RAMS_comp_qwtk(nx,ny,nz,np,inqoutt,inwoutl,soil_text) nsoil = nint(soil_text(x,y,z,p)) dryhcap = soil(nsoil)%slcpd !----- Compute temperature and liquid water fraction. ----------------------! - call qwtk(energy,water,dryhcap,temperature,fracliq) + call uextcm2tl(energy,water,dryhcap,temperature,fracliq) !----- Save in the variables that will be returned. ------------------------! inqoutt(x,y,z,p) = temperature inwoutl(x,y,z,p) = fracliq @@ -2821,7 +2788,7 @@ subroutine RAMS_comp_qwtk(nx,ny,nz,np,inqoutt,inwoutl,soil_text) end do return -end subroutine RAMS_comp_qwtk +end subroutine RAMS_comp_uextcm2tl !==========================================================================================! !==========================================================================================! @@ -2833,7 +2800,7 @@ end subroutine RAMS_comp_qwtk !==========================================================================================! !==========================================================================================! subroutine RAMS_comp_copysst(nx,ny,nz,inqoutt) - use therm_lib , only : qtk ! ! subroutine + use therm_lib , only : uint2tl ! ! subroutine implicit none !----- Arguments. ----------------------------------------------------------------------! integer , intent(in) :: nx @@ -2853,7 +2820,7 @@ subroutine RAMS_comp_copysst(nx,ny,nz,inqoutt) do y=1,ny do x=1,nx energy = inqoutt(x,y,nz) - call qtk(energy,temperature(x,y),fracliq) + call uint2tl(energy,temperature(x,y),fracliq) end do end do @@ -3061,3 +3028,54 @@ end subroutine RAMS_comp_zenith !==========================================================================================! !==========================================================================================! + + + + + +!==========================================================================================! +!==========================================================================================! +subroutine RAMS_comp_wflx2latent(nx,ny,np,wflx,temp) + use rconstants, only : t3ple & ! intent(in) + , alvl3 & ! intent(in) + , alvi3 ! ! intent(in) + use therm_lib , only : alvl & ! function + , alvi ! ! function + implicit none + !----- Arguments. ----------------------------------------------------------------------! + integer , intent(in) :: nx + integer , intent(in) :: ny + integer , intent(in) :: np + real , dimension(nx,ny,np), intent(inout) :: wflx + real , dimension(nx,ny,np), intent(in) :: temp + !----- Local variables. ----------------------------------------------------------------! + integer :: p + integer :: x + integer :: y + real :: latent + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + do p=1,np + do y=1,ny + do x=1,nx + if (temp(x,y,p) == t3ple) then + latent = 0.5 * (alvl3 + alvi3) + elseif (temp(x,y,p) > t3ple) then + latent = alvl(temp(x,y,p)) + else + latent = alvi(temp(x,y,p)) + end if + wflx(x,y,p) = wflx(x,y,p) * latent + end do + end do + end do + !---------------------------------------------------------------------------------------! + + return +end subroutine RAMS_comp_wflx2latent +!==========================================================================================! +!==========================================================================================! + diff --git a/Ramspost/src/lib/therm_lib.f90 b/Ramspost/src/lib/therm_lib.f90 index 72b8c598b..0468390af 100644 --- a/Ramspost/src/lib/therm_lib.f90 +++ b/Ramspost/src/lib/therm_lib.f90 @@ -57,13 +57,16 @@ module therm_lib ! These equations give the triple point at t3ple, with vapour pressure being es3ple. ! !---------------------------------------------------------------------------------------! !----- Coefficients based on equation (7): ---------------------------------------------! - real, dimension(0:3), parameter :: iii_7 = (/ 9.550426,-5723.265, 3.53068,-0.00728332 /) + real(kind=4), dimension(0:3), parameter :: iii_7 = (/ 9.550426, -5723.265 & + , 3.530680, -0.00728332 /) !----- Coefficients based on equation (10), first fit ----------------------------------! - real, dimension(0:3), parameter :: l01_10= (/54.842763,-6763.22 ,-4.210 , 0.000367 /) + real(kind=4), dimension(0:3), parameter :: l01_10 = (/ 54.842763, -6763.220 & + , -4.210 , 0.000367 /) !----- Coefficients based on equation (10), second fit ---------------------------------! - real, dimension(0:3), parameter :: l02_10= (/53.878 ,-1331.22 ,-9.44523, 0.014025 /) + real(kind=4), dimension(0:3), parameter :: l02_10 = (/ 53.878 , -1331.22 & + , -9.44523 , 0.014025 /) !----- Coefficients based on the hyperbolic tangent ------------------------------------! - real, dimension(2) , parameter :: ttt_10= (/0.0415,218.8/) + real(kind=4), dimension(2) , parameter :: ttt_10 = (/ 0.0415 , 218.80 /) !---------------------------------------------------------------------------------------! @@ -80,44 +83,70 @@ module therm_lib ! what was on the original code... ! !---------------------------------------------------------------------------------------! !----- Coefficients for esat (liquid) --------------------------------------------------! - real, dimension(0:8), parameter :: cll = (/ .6105851e+03, .4440316e+02, .1430341e+01 & - , .2641412e-01, .2995057e-03, .2031998e-05 & - , .6936113e-08, .2564861e-11, -.3704404e-13 /) + real(kind=4), dimension(0:8), parameter :: cll = (/ .6105851e+03, .4440316e+02 & + , .1430341e+01, .2641412e-01 & + , .2995057e-03, .2031998e-05 & + , .6936113e-08, .2564861e-11 & + , -.3704404e-13 /) !----- Coefficients for esat (ice) -----------------------------------------------------! - real, dimension(0:8), parameter :: cii = (/ .6114327e+03, .5027041e+02, .1875982e+01 & - , .4158303e-01, .5992408e-03, .5743775e-05 & - , .3566847e-07, .1306802e-09, .2152144e-12 /) + real(kind=4), dimension(0:8), parameter :: cii = (/ .6114327e+03, .5027041e+02 & + , .1875982e+01, .4158303e-01 & + , .5992408e-03, .5743775e-05 & + , .3566847e-07, .1306802e-09 & + , .2152144e-12 /) !----- Coefficients for d(esat)/dT (liquid) --------------------------------------------! - real, dimension(0:8), parameter :: dll = (/ .4443216e+02, .2861503e+01, .7943347e-01 & - , .1209650e-02, .1036937e-04, .4058663e-07 & - ,-.5805342e-10, -.1159088e-11, -.3189651e-14 /) + real(kind=4), dimension(0:8), parameter :: dll = (/ .4443216e+02, .2861503e+01 & + , .7943347e-01, .1209650e-02 & + , .1036937e-04, .4058663e-07 & + , -.5805342e-10, -.1159088e-11 & + , -.3189651e-14 /) !----- Coefficients for esat (ice) -----------------------------------------------------! - real, dimension(0:8), parameter :: dii = (/ .5036342e+02, .3775758e+01, .1269736e+00 & - , .2503052e-02, .3163761e-04, .2623881e-06 & - , .1392546e-08, .4315126e-11, .5961476e-14 /) - !---------------------------------------------------------------------------------------! - + real(kind=4), dimension(0:8), parameter :: dii = (/ .5036342e+02, .3775758e+01 & + , .1269736e+00, .2503052e-02 & + , .3163761e-04, .2623881e-06 & + , .1392546e-08, .4315126e-11 & + , .5961476e-14 /) + !=======================================================================================! + !=======================================================================================! contains + + + !=======================================================================================! !=======================================================================================! ! This function calculates the liquid saturation vapour pressure as a function of ! ! Kelvin temperature. This expression came from MK05, equation (10). ! !---------------------------------------------------------------------------------------! - real function eslf(temp,l1funout,l2funout,ttfunout) - use rconstants, only : t00 + real(kind=4) function eslf(temp,l1funout,l2funout,ttfunout) + use rconstants , only : t00 ! ! intent(in) implicit none - real, intent(in) :: temp - real, intent(out), optional :: l1funout,ttfunout,l2funout - real :: l1fun,ttfun,l2fun,x + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! + real(kind=4), intent(out), optional :: l1funout ! Function for high temperatures + real(kind=4), intent(out), optional :: ttfunout ! Interpolation function + real(kind=4), intent(out), optional :: l2funout ! Function for low temperatures + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: l1fun ! + real(kind=4) :: ttfun ! + real(kind=4) :: l2fun ! + real(kind=4) :: x ! + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Choose between the old and the new thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then !----- Updated method, using MK05 ------------------------------------------------! l1fun = l01_10(0) + l01_10(1)/temp + l01_10(2)*log(temp) + l01_10(3) * temp l2fun = l02_10(0) + l02_10(1)/temp + l02_10(2)*log(temp) + l02_10(3) * temp ttfun = tanh(ttt_10(1) * (temp - ttt_10(2))) eslf = exp(l1fun + ttfun*l2fun) + !---------------------------------------------------------------------------------! if (present(l1funout)) l1funout = l1fun if (present(l2funout)) l2funout = l2fun @@ -127,6 +156,7 @@ real function eslf(temp,l1funout,l2funout,ttfunout) x = max(-80.,temp-t00) eslf = cll(0) + x * (cll(1) + x * (cll(2) + x * (cll(3) + x * (cll(4) & + x * (cll(5) + x * (cll(6) + x * (cll(7) + x * cll(8)) ) ) ) ) ) ) + !---------------------------------------------------------------------------------! if (present(l1funout)) l1funout = eslf if (present(l2funout)) l2funout = eslf @@ -148,28 +178,42 @@ end function eslf ! This function calculates the ice saturation vapour pressure as a function of ! ! Kelvin temperature, based on MK05 equation (7). ! !---------------------------------------------------------------------------------------! - real function esif(temp,iifunout) - use rconstants, only : t00 + real(kind=4) function esif(temp,iifunout) + use rconstants , only : t00 ! ! intent(in) implicit none - real, intent(in) :: temp - real, intent(out), optional :: iifunout - real :: iifun,x + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! + real(kind=4), intent(out), optional :: iifunout + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: iifun + real(kind=4) :: x + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Choose between the old and the new thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then !----- Updated method, using MK05 ------------------------------------------------! iifun = iii_7(0) + iii_7(1)/temp + iii_7(2) * log(temp) + iii_7(3) * temp esif = exp(iifun) - + !---------------------------------------------------------------------------------! + + if (present(iifunout)) iifunout=iifun else !----- Original method, using polynomial fit (FWC92) -----------------------------! x=max(-80.,temp-t00) esif = cii(0) + x * (cii(1) + x * (cii(2) + x * (cii(3) + x * (cii(4) & + x * (cii(5) + x * (cii(6) + x * (cii(7) + x * cii(8)) ) ) ) ) ) ) + !---------------------------------------------------------------------------------! if (present(iifunout)) iifunout=esif end if + !------------------------------------------------------------------------------------! + return end function esif !=======================================================================================! @@ -186,24 +230,44 @@ end function esif ! temperature. It chooses which phase to look depending on whether the temperature is ! ! below or above the triple point. ! !---------------------------------------------------------------------------------------! - real function eslif(temp,useice) - use rconstants, only: t3ple + real(kind=4) function eslif(temp,useice) + use rconstants , only : t3ple ! ! intent(in) implicit none - real , intent(in) :: temp - logical, intent(in), optional :: useice - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice + !----- Local variables. -------------------------------------------------------------! + logical :: frozen + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple end if + !------------------------------------------------------------------------------------! + - if (brrr_cold) then - eslif = esif(temp) ! Ice saturation vapour pressure + + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- Saturation vapour pressure for ice. ---------------------------------------! + eslif = esif(temp) + !---------------------------------------------------------------------------------! else - eslif = eslf(temp) ! Liquid saturation vapour pressure + !----- Saturation vapour pressure for liquid. ------------------------------------! + eslif = eslf(temp) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return end function eslif @@ -220,14 +284,29 @@ end function eslif ! This function calculates the liquid saturation vapour mixing ratio as a function ! ! of pressure and Kelvin temperature. ! !---------------------------------------------------------------------------------------! - real function rslf(pres,temp) - use rconstants, only : ep,toodry + real(kind=4) function rslf(pres,temp) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real, intent(in) :: pres,temp - real :: esl + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esl ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + !----- First we find the saturation vapour pressure. --------------------------------! esl = eslf(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the mixing ! + ! ratio. ! + !------------------------------------------------------------------------------------! rslf = max(toodry,ep*esl/(pres-esl)) + !------------------------------------------------------------------------------------! return end function rslf @@ -244,14 +323,29 @@ end function rslf ! This function calculates the ice saturation vapour mixing ratio as a function of ! ! pressure and Kelvin temperature. ! !---------------------------------------------------------------------------------------! - real function rsif(pres,temp) - use rconstants, only : ep,toodry + real(kind=4) function rsif(pres,temp) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real, intent(in) :: pres,temp - real :: esi + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esi ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + !----- First we find the saturation vapour pressure. --------------------------------! esi = esif(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the mixing ! + ! ratio. ! + !------------------------------------------------------------------------------------! rsif = max(toodry,ep*esi/(pres-esi)) + !------------------------------------------------------------------------------------! return end function rsif @@ -268,29 +362,55 @@ end function rsif ! This function calculates the saturation vapour mixing ratio, over liquid or ice ! ! depending on temperature, as a function of pressure and Kelvin temperature. ! !---------------------------------------------------------------------------------------! - real function rslif(pres,temp,useice) - use rconstants, only: t3ple,ep + real(kind=4) function rslif(pres,temp,useice) + use rconstants , only : t3ple & ! intent(in) + , ep ! ! intent(in) implicit none - real , intent(in) :: pres,temp - logical, intent(in), optional :: useice - real :: esz - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: pres + real(kind=4), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esz + logical :: frozen + !------------------------------------------------------------------------------------! - !----- Checking which saturation (liquid or ice) I should use here ------------------! + + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple end if + !------------------------------------------------------------------------------------! + - !----- Finding the saturation vapour pressure ---------------------------------------! - if (brrr_cold) then + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- Saturation vapour pressure for ice. ---------------------------------------! esz = esif(temp) + !---------------------------------------------------------------------------------! else + !----- Saturation vapour pressure for liquid. ------------------------------------! esz = eslf(temp) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the mixing ! + ! ratio. ! + !------------------------------------------------------------------------------------! rslif = ep * esz / (pres - esz) + !------------------------------------------------------------------------------------! return end function rslif @@ -302,19 +422,179 @@ end function rslif + !=======================================================================================! + !=======================================================================================! + ! This function calculates the liquid saturation specific humidity as a function of ! + ! pressure and Kelvin temperature. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function qslf(pres,temp) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esl ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- First we find the saturation vapour pressure. --------------------------------! + esl = eslf(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the ! + ! specific humidity. ! + !------------------------------------------------------------------------------------! + qslf = max(toodry,ep * esl/( pres - (1.0 - ep) * esl) ) + !------------------------------------------------------------------------------------! + + return + end function qslf + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function calculates the ice saturation specific humidity as a function of ! + ! pressure and Kelvin temperature. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function qsif(pres,temp) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esi ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- First we find the saturation vapour pressure. --------------------------------! + esi = esif(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the ! + ! specific humidity. ! + !------------------------------------------------------------------------------------! + qsif = max(toodry,ep * esi/( pres - (1.0 - ep) * esi) ) + !------------------------------------------------------------------------------------! + + return + end function qsif + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function calculates the saturation specific humidity, over liquid or ice ! + ! depending on temperature, as a function of pressure and Kelvin temperature. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function qslif(pres,temp,useice) + use rconstants , only : t3ple & ! intent(in) + , ep & ! intent(in) + , toodry ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: pres + real(kind=4), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esz + logical :: frozen + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! + if (present(useice)) then + frozen = useice .and. temp < t3ple + else + frozen = bulk_on .and. temp < t3ple + end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- Saturation vapour pressure for ice. ---------------------------------------! + esz = esif(temp) + !---------------------------------------------------------------------------------! + else + !----- Saturation vapour pressure for liquid. ------------------------------------! + esz = eslf(temp) + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Use the usual relation between pressure and vapour pressure to find the ! + ! specific humidity. ! + !------------------------------------------------------------------------------------! + qslif = max(toodry, ep * esz/( pres - (1.0 - ep) * esz) ) + !------------------------------------------------------------------------------------! + + return + end function qslif + !=======================================================================================! + !=======================================================================================! + + + + + + !=======================================================================================! !=======================================================================================! ! This function calculates the vapour-liquid equilibrium density for vapour, as a ! ! function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! - real function rhovsl(temp) - use rconstants, only : rh2o + real(kind=4) function rhovsl(temp) + use rconstants , only : rh2o ! ! intent(in) implicit none - real, intent(in) :: temp - real :: eequ + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: eequ ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the equilibrium (saturation) vapour pressure. ! + !------------------------------------------------------------------------------------! eequ = eslf(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the saturation density. ! + !------------------------------------------------------------------------------------! rhovsl = eequ / (rh2o * temp) + !------------------------------------------------------------------------------------! + return end function rhovsl !=======================================================================================! @@ -331,13 +611,29 @@ end function rhovsl ! This function calculates the vapour-ice equilibrium density for vapour, as a ! ! function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! - real function rhovsi(temp) - use rconstants, only : rh2o + real(kind=4) function rhovsi(temp) + use rconstants , only : rh2o ! ! intent(in) implicit none - real, intent(in) :: temp - real :: eequ + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: eequ ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the equilibrium (saturation) vapour pressure. ! + !------------------------------------------------------------------------------------! eequ = esif(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the saturation density. ! + !------------------------------------------------------------------------------------! rhovsi = eequ / (rh2o * temp) + !------------------------------------------------------------------------------------! + return end function rhovsi !=======================================================================================! @@ -348,27 +644,42 @@ end function rhovsi - !=======================================================================================! !=======================================================================================! ! This function calculates the saturation density for vapour, as a function of tem- ! ! perature in Kelvin. It will decide between ice-vapour or liquid-vapour based on the ! ! temperature. ! !---------------------------------------------------------------------------------------! - real function rhovsil(temp,useice) - use rconstants, only : rh2o + real(kind=4) function rhovsil(temp,useice) + use rconstants , only : rh2o ! ! intent(in) implicit none - real, intent(in) :: temp - logical, intent(in), optional :: useice - real :: eequ + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: eequ + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Pass the "useice" argument to eslif, so it may decide whether ice thermo- ! + ! dynamics is to be used. ! + !------------------------------------------------------------------------------------! if (present(useice)) then eequ = eslif(temp,useice) else eequ = eslif(temp) end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the saturation density. ! + !------------------------------------------------------------------------------------! rhovsil = eequ / (rh2o * temp) + !------------------------------------------------------------------------------------! return end function rhovsil @@ -385,25 +696,40 @@ end function rhovsil ! This function calculates the partial derivative of liquid saturation vapour ! ! pressure with respect to temperature as a function of Kelvin temperature. ! !---------------------------------------------------------------------------------------! - real function eslfp(temp) - use rconstants, only: t00 + real(kind=4) function eslfp(temp) + use rconstants , only : t00 ! ! intent(in) implicit none - real, intent(in) :: temp - real :: esl,l2fun,ttfun,l1prime,l2prime,ttprime,x + !------ Arguments. ------------------------------------------------------------------! + real(kind=4), intent(in) :: temp + !------ Local variables. ------------------------------------------------------------! + real(kind=4) :: esl + real(kind=4) :: l2fun + real(kind=4) :: ttfun + real(kind=4) :: l1prime + real(kind=4) :: l2prime + real(kind=4) :: ttprime + real(kind=4) :: x + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide which function to use, based on the thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then !----- Updated method, using MK05 ------------------------------------------------! - esl = eslf(temp,l2funout=l2fun,ttfunout=ttfun) + esl = eslf(temp,l2funout=l2fun,ttfunout=ttfun) l1prime = -l01_10(1)/(temp*temp) + l01_10(2)/temp + l01_10(3) l2prime = -l02_10(1)/(temp*temp) + l02_10(2)/temp + l02_10(3) ttprime = ttt_10(1)*(1.-ttfun*ttfun) - eslfp = esl * (l1prime + l2prime*ttfun + l2fun*ttprime) + eslfp = esl * (l1prime + l2prime*ttfun + l2fun*ttprime) else !----- Original method, using polynomial fit (FWC92) -----------------------------! - x=max(-80.,temp-t00) + x = max(-80.,temp-t00) eslfp = dll(0) + x * (dll(1) + x * (dll(2) + x * (dll(3) + x * (dll(4) & + x * (dll(5) + x * (dll(6) + x * (dll(7) + x * dll(8)) ) ) ) ) ) ) end if + !------------------------------------------------------------------------------------! return @@ -421,12 +747,22 @@ end function eslfp ! This function calculates the partial derivative of ice saturation vapour pressure ! ! with respect to temperature as a function of Kelvin temperature. ! !---------------------------------------------------------------------------------------! - real function esifp(temp) - use rconstants, only: lsorvap, t00 + real(kind=4) function esifp(temp) + use rconstants , only : t00 ! ! intent(in) implicit none - real, intent(in) :: temp - real :: esi,iiprime,x + !------ Arguments. ------------------------------------------------------------------! + real(kind=4), intent(in) :: temp + !------ Local variables. ------------------------------------------------------------! + real(kind=4) :: esi + real(kind=4) :: iiprime + real(kind=4) :: x + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide which function to use, based on the thermodynamics. ! + !------------------------------------------------------------------------------------! if (newthermo) then !----- Updated method, using MK05 ------------------------------------------------! esi = esif(temp) @@ -438,6 +774,7 @@ real function esifp(temp) esifp = dii(0) + x * (dii(1) + x * (dii(2) + x * (dii(3) + x * (dii(4) & + x * (dii(5) + x * (dii(6) + x * (dii(7) + x * dii(8)) ) ) ) ) ) ) end if + !------------------------------------------------------------------------------------! return end function esifp @@ -455,24 +792,44 @@ end function esifp ! a function of Kelvin temperature. It chooses which phase to look depending on ! ! whether the temperature is below or above the triple point. ! !---------------------------------------------------------------------------------------! - real function eslifp(temp,useice) - use rconstants, only: t3ple + real(kind=4) function eslifp(temp,useice) + use rconstants , only : t3ple ! ! intent(in) implicit none - real , intent(in) :: temp - logical, intent(in), optional :: useice - logical :: brrr_cold + !------ Arguments. ------------------------------------------------------------------! + real(kind=4), intent(in) :: temp + !------ Local variables. ------------------------------------------------------------! + logical , intent(in), optional :: useice + logical :: frozen + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide which function to use (saturation for liquid water or ice). ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple end if + !------------------------------------------------------------------------------------! + + - if (brrr_cold) then - eslifp = esifp(temp) ! d(Ice saturation vapour pressure)/dT + !------------------------------------------------------------------------------------! + ! Call the appropriate function depending on the temperature and whether ice ! + ! thermodynamics is to be used. ! + !------------------------------------------------------------------------------------! + if (frozen) then + !----- d(Saturation vapour pressure)/dT for ice. ---------------------------------! + eslifp = esifp(temp) + !---------------------------------------------------------------------------------! else - eslifp = eslfp(temp) ! d(Liquid saturation vapour pressure)/dT + !----- d(Saturation vapour pressure)/dT for liquid water. ------------------------! + eslifp = eslfp(temp) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return end function eslifp @@ -491,17 +848,37 @@ end function eslifp ! ing ratio with respect to temperature as a function of pressure and Kelvin tempera- ! ! ture. ! !---------------------------------------------------------------------------------------! - real function rslfp(pres,temp) - use rconstants, only: ep + real(kind=4) function rslfp(pres,temp) + use rconstants , only : ep ! ! intent(in) implicit none - real, intent(in) :: pres,temp - real :: desdt,esl,pdry + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esl ! Partial pressure [ Pa] + real(kind=4) :: desdt ! Derivative of partial pressure of water [ Pa/K] + real(kind=4) :: pdry ! Partial pressure of dry air [ Pa] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! esl = eslf(temp) desdt = eslfp(temp) - + !------------------------------------------------------------------------------------! + + + !----- Find the partial pressure of dry air. ----------------------------------------! pdry = pres-esl + !------------------------------------------------------------------------------------! + + + !----- Find the partial derivative of mixing ratio. ---------------------------------! rslfp = ep * pres * desdt / (pdry*pdry) + !------------------------------------------------------------------------------------! return end function rslfp @@ -520,18 +897,36 @@ end function rslfp ! ing ratio with respect to temperature as a function of pressure and Kelvin tempera- ! ! ture. ! !---------------------------------------------------------------------------------------! - real function rsifp(pres,temp) - use rconstants, only: ep + real(kind=4) function rsifp(pres,temp) + use rconstants , only : ep ! ! intent(in) implicit none - real, intent(in) :: pres,temp - real :: desdt,esi,pdry + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: esi ! Partial pressure [ Pa] + real(kind=4) :: desdt ! Derivative of partial pressure of water [ Pa/K] + real(kind=4) :: pdry ! Partial pressure of dry air [ Pa] + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! esi = esif(temp) desdt = esifp(temp) - - pdry = pres-esi - rsifp = ep * pres * desdt / (pdry*pdry) + !------------------------------------------------------------------------------------! + + !----- Find the partial pressure of dry air. ----------------------------------------! + pdry = pres-esi + !------------------------------------------------------------------------------------! + + + !----- Find the partial derivative of mixing ratio. ---------------------------------! + rsifp = ep * pres * desdt / (pdry*pdry) + !------------------------------------------------------------------------------------! return end function rsifp !=======================================================================================! @@ -549,25 +944,42 @@ end function rsifp ! ing ratio with respect to temperature as a function of pressure and Kelvin tempera- ! ! ture. ! !---------------------------------------------------------------------------------------! - real function rslifp(pres,temp,useice) - use rconstants, only: t3ple + real(kind=4) function rslifp(pres,temp,useice) + use rconstants , only: t3ple ! ! intent(in) implicit none - real , intent(in) :: pres,temp - logical, intent(in), optional :: useice - real :: desdt - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics? [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: desdt ! Derivative of vapour pressure [ Pa/K] + logical :: frozen ! Use the ice thermodynamics [ T|F] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide whether to use liquid water of ice for saturation, based on the temper- ! + ! ature and the settings. ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple end if + !------------------------------------------------------------------------------------! - if (brrr_cold) then - rslifp=rsifp(pres,temp) + + !------------------------------------------------------------------------------------! + ! Call the function depending on the previous check. ! + !------------------------------------------------------------------------------------! + if (frozen) then + rslifp = rsifp(pres,temp) else - rslifp=rslfp(pres,temp) + rslifp = rslfp(pres,temp) end if + !------------------------------------------------------------------------------------! return end function rslifp @@ -585,15 +997,30 @@ end function rslifp ! This function calculates the derivative of vapour-liquid equilibrium density, as ! ! a function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! - real function rhovslp(temp) - use rconstants, only : rh2o + real(kind=4) function rhovslp(temp) + use rconstants , only : rh2o ! ! intent(in) implicit none - real, intent(in) :: temp - real :: es,desdt + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: es ! Vapour pressure [ Pa] + real(kind=4) :: desdt ! Vapour pressure derivative [ Pa/K] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! es = eslf(temp) desdt = eslfp(temp) + !------------------------------------------------------------------------------------! + + + !----- Find the partial derivative of saturation density . --------------------------! rhovslp = (desdt-es/temp) / (rh2o * temp) + !------------------------------------------------------------------------------------! return end function rhovslp @@ -611,15 +1038,30 @@ end function rhovslp ! This function calculates the derivative of vapour-ice equilibrium density, as a ! ! function of temperature in Kelvin. ! !---------------------------------------------------------------------------------------! - real function rhovsip(temp) - use rconstants, only : rh2o + real(kind=4) function rhovsip(temp) + use rconstants , only : rh2o ! ! intent(in) implicit none - real, intent(in) :: temp - real :: es,desdt + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: es ! Vapour pressure [ Pa] + real(kind=4) :: desdt ! Vapour pressure derivative [ Pa/K] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the partial pressure of water vapour and its derivative, using temper- ! + ! ature. ! + !------------------------------------------------------------------------------------! es = esif(temp) desdt = esifp(temp) + !------------------------------------------------------------------------------------! + + + !----- Find the partial derivative of saturation density . --------------------------! rhovsip = (desdt-es/temp) / (rh2o * temp) + !------------------------------------------------------------------------------------! return end function rhovsip @@ -638,24 +1080,40 @@ end function rhovsip ! function of temperature in Kelvin. It will decide between ice-vapour or liquid-vapour ! ! based on the temperature. ! !---------------------------------------------------------------------------------------! - real function rhovsilp(temp,useice) - use rconstants, only: t3ple + real(kind=4) function rhovsilp(temp,useice) + use rconstants , only : t3ple ! ! intent(in) implicit none - real, intent(in) :: temp - logical, intent(in), optional :: useice - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics? [ T|F] + !----- Local variables. -------------------------------------------------------------! + logical :: frozen ! Derivative of vapour pressure [ Pa/K] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Decide whether to use liquid water of ice for saturation, based on the temper- ! + ! ature and the settings. ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple end if + !------------------------------------------------------------------------------------! + - if (brrr_cold) then - rhovsilp=rhovsip(temp) + !------------------------------------------------------------------------------------! + ! Call the function depending on the previous check. ! + !------------------------------------------------------------------------------------! + if (frozen) then + rhovsilp = rhovsip(temp) else - rhovsilp=rhovslp(temp) + rhovsilp = rhovslp(temp) end if + !------------------------------------------------------------------------------------! return end function rhovsilp @@ -676,81 +1134,120 @@ end function rhovsilp ! the unlikely case in which Newton's method fails, switch back to modified Regula ! ! Falsi method (Illinois). ! !---------------------------------------------------------------------------------------! - real function tslf(pvap) + real(kind=4) function tslf(pvap) - implicit none - !----- Argument ---------------------------------------------------------------------! - real, intent(in) :: pvap ! Saturation vapour pressure [ Pa] - !----- Local variables for iterative method -----------------------------------------! - real :: deriv ! Function derivative [ Pa] - real :: fun ! Function for which we seek a root. [ Pa] - real :: funa ! Smallest guess function [ Pa] - real :: funz ! Largest guess function [ Pa] - real :: tempa ! Smallest guess (or previous guess) [ Pa] - real :: tempz ! Largest guess (or new guess in Newton) [ Pa] - real :: delta ! Aux. var --- 2nd guess for bisection [ ] - integer :: itn,itb ! Iteration counter [ ---] - logical :: converged ! Convergence handle [ ---] - logical :: zside ! Flag to check for one-sided approach... [ ---] - !------------------------------------------------------------------------------------! - - !----- First Guess, using Bolton (1980) equation 11, giving es in Pa and T in K -----! + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pvap ! Saturation vapour pressure [ Pa] + !----- Local variables for iterative method. ----------------------------------------! + real(kind=4) :: deriv ! Function derivative [ Pa] + real(kind=4) :: fun ! Function for which we seek a root. [ Pa] + real(kind=4) :: funa ! Smallest guess function [ Pa] + real(kind=4) :: funz ! Largest guess function [ Pa] + real(kind=4) :: tempa ! Smallest guess (or previous guess) [ Pa] + real(kind=4) :: tempz ! Largest guess (new guess in Newton) [ Pa] + real(kind=4) :: delta ! Aux. var --- 2nd guess for bisection [ ] + integer :: itn ! Iteration counter [ ---] + integer :: itb ! Iteration counter [ ---] + logical :: converged ! Convergence handle [ ---] + logical :: zside ! Flag to check for one-sided approach [ ---] + !------------------------------------------------------------------------------------! + + !----- First Guess, use Bolton (1980) equation 11, giving es in Pa and T in K -------! tempa = (29.65 * log(pvap) - 5016.78)/(log(pvap)-24.0854) funa = eslf(tempa) - pvap deriv = eslfp(tempa) - !----- Copying just in case it fails at the first iteration -------------------------! + !------------------------------------------------------------------------------------! + + + !----- Copy just in case it fails at the first iteration ----------------------------! tempz = tempa fun = funa - + !------------------------------------------------------------------------------------! + + !----- Enter Newton's method loop: --------------------------------------------------! converged = .false. newloop: do itn = 1,maxfpo/6 if (abs(deriv) < toler) exit newloop !----- Too dangerous, go with bisection -----! - !----- Copying the previous guess ------------------------------------------------! + + !----- Copy the previous guess. --------------------------------------------------! tempa = tempz funa = fun - !----- New guess, its function and derivative evaluation -------------------------! + !---------------------------------------------------------------------------------! + + + !----- New guess, its function, and derivative evaluation. -----------------------! tempz = tempa - fun/deriv fun = eslf(tempz) - pvap deriv = eslfp(tempz) - + !---------------------------------------------------------------------------------! + + + !----- Check convergence. --------------------------------------------------------! converged = abs(tempa-tempz) < toler * tempz if (converged) then - tslf = 0.5*(tempa+tempz) + tslf = 0.5 * (tempa+tempz) return - elseif (fun ==0) then !Converged by luck! + elseif (fun == 0.0) then + !----- Converged by luck. -----------------------------------------------------! tslf = tempz return end if + !---------------------------------------------------------------------------------! end do newloop + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! If we have reached this point, then Newton's method has failed. Use bisection ! + ! instead. For bisection, we need two guesses whose function has opposite signs. ! !------------------------------------------------------------------------------------! if (funa * fun < 0.) then + !----- We already have two guesses with opposite signs. --------------------------! funz = fun zside = .true. + !---------------------------------------------------------------------------------! else + !----- Need to find the guesses with opposite signs. -----------------------------! if (abs(fun-funa) < 100.*toler*tempa) then delta = 100.*toler*tempa else delta = max(abs(funa * (tempz-tempa)/(fun-funa)),100.*toler*tempa) end if + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! Try guesses on both sides of the first guess, increasingly further away ! + ! until we spot a good guess. ! + !---------------------------------------------------------------------------------! tempz = tempa + delta zside = .false. zgssloop: do itb=1,maxfpo tempz = tempa + real((-1)**itb * (itb+3)/2) * delta funz = eslf(tempz) - pvap - zside = funa*funz < 0 + zside = funa*funz < 0. if (zside) exit zgssloop end do zgssloop if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempa=',tempa,'funa=',funa - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempz=',tempz,'func=',funz - call abort_run('Failed finding the second guess for regula falsi' & - ,'tslf','therm_lib.f90') + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the second guess:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' + call abort_run ('Failed finding the second guess for regula falsi' & + ,'tslf','therm_lib.f90') end if end if @@ -759,36 +1256,52 @@ real function tslf(pvap) tslf = (funz*tempa-funa*tempz)/(funz-funa) !---------------------------------------------------------------------------------! - ! Now that we updated the guess, check whether they are really close. If so, ! + ! Now that we updated the guess, check whether they are really close. If so, ! ! it converged, I can use this as my guess. ! !---------------------------------------------------------------------------------! converged = abs(tslf-tempa) < toler * tslf if (converged) exit bisloop - !------ Finding the new function -------------------------------------------------! + !------ Find the new function evaluation. ----------------------------------------! fun = eslf(tslf) - pvap + !---------------------------------------------------------------------------------! - !------ Defining my new interval based on the intermediate value theorem. --------! + + !------ Define the new interval based on the intermediate value theorem. ---------! if (fun*funa < 0. ) then tempz = tslf funz = fun - !----- If we are updating zside again, modify aside (Illinois method) ---------! + !----- If we are updating zside again, modify aside (Illinois method). --------! if (zside) funa=funa * 0.5 - !----- We just updated zside, setting zside to true. --------------------------! + !----- We have just updated zside, so we set zside to true. -------------------! zside = .true. else tempa = tslf funa = fun - !----- If we are updating aside again, modify aside (Illinois method) ---------! + !----- If we are updating aside again, modify zside (Illinois method). --------! if (.not. zside) funz=funz * 0.5 - !----- We just updated aside, setting aside to true. --------------------------! + !----- We have just updated aside, so we set zside to false. ------------------! zside = .false. end if end do bisloop if (.not.converged) then - call abort_run('Temperature didn''t converge, giving up!!!' & - ,'tslf','therm_lib.f90') + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the solution:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' + call abort_run ('Temperature didn''t converge, we give up!!!' & + ,'tslf','therm_lib.f90') end if return @@ -809,44 +1322,56 @@ end function tslf ! the unlikely case in which Newton's method fails, switch back to modified Regula ! ! Falsi method (Illinois). ! !---------------------------------------------------------------------------------------! - real function tsif(pvap) + real(kind=4) function tsif(pvap) - implicit none - !----- Argument ---------------------------------------------------------------------! - real, intent(in) :: pvap ! Saturation vapour pressure [ Pa] + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pvap ! Saturation vapour pressure [ Pa] !----- Local variables for iterative method -----------------------------------------! - real :: deriv ! Function derivative [ Pa] - real :: fun ! Function for which we seek a root. [ Pa] - real :: funa ! Smallest guess function [ Pa] - real :: funz ! Largest guess function [ Pa] - real :: tempa ! Smallest guess (or previous guess) [ Pa] - real :: tempz ! Largest guess (or new guess in Newton) [ Pa] - real :: delta ! Aux. var --- 2nd guess for bisection [ ] - integer :: itn,itb ! Iteration counter [ ---] - logical :: converged ! Convergence handle [ ---] - logical :: zside ! Flag to check for one-sided approach... [ ---] - !------------------------------------------------------------------------------------! - - !----- First Guess, using Murphy-Koop (2005), equation 8. ---------------------------! + real(kind=4) :: deriv ! Function derivative [ Pa] + real(kind=4) :: fun ! Function for which we seek a root. [ Pa] + real(kind=4) :: funa ! Smallest guess function [ Pa] + real(kind=4) :: funz ! Largest guess function [ Pa] + real(kind=4) :: tempa ! Smallest guess (or previous guess) [ Pa] + real(kind=4) :: tempz ! Largest guess (new guess in Newton) [ Pa] + real(kind=4) :: delta ! Aux. var --- 2nd guess for bisection [ ] + integer :: itn + integer :: itb ! Iteration counter [ ---] + logical :: converged ! Convergence handle [ ---] + logical :: zside ! Flag to check for one-sided approach [ ---] + !------------------------------------------------------------------------------------! + + !----- First Guess, use Murphy-Koop (2005), equation 8. -----------------------------! tempa = (1.814625 * log(pvap) +6190.134)/(29.120 - log(pvap)) funa = esif(tempa) - pvap deriv = esifp(tempa) - !----- Copying just in case it fails at the first iteration -------------------------! + !------------------------------------------------------------------------------------! + + + !----- Copy just in case it fails at the first iteration ----------------------------! tempz = tempa fun = funa - + !------------------------------------------------------------------------------------! + + !----- Enter Newton's method loop: --------------------------------------------------! converged = .false. newloop: do itn = 1,maxfpo/6 if (abs(deriv) < toler) exit newloop !----- Too dangerous, go with bisection -----! - !----- Copying the previous guess ------------------------------------------------! + + !----- Copy the previous guess. --------------------------------------------------! tempa = tempz funa = fun - !----- New guess, its function and derivative evaluation -------------------------! + + + !----- New guess, its function, and derivative evaluation. -----------------------! tempz = tempa - fun/deriv fun = esif(tempz) - pvap deriv = esifp(tempz) - + !---------------------------------------------------------------------------------! + + + !----- Check convergence. --------------------------------------------------------! converged = abs(tempa-tempz) < toler * tempz if (converged) then tsif = 0.5*(tempa+tempz) @@ -856,34 +1381,58 @@ real function tsif(pvap) return end if end do newloop + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! If we have reached this point, then Newton's method has failed. Use bisection ! + ! instead. For bisection, we need two guesses whose function has opposite signs. ! !------------------------------------------------------------------------------------! if (funa * fun < 0.) then + !----- We already have two guesses with opposite signs. --------------------------! funz = fun zside = .true. + !---------------------------------------------------------------------------------! else + !----- Need to find the guesses with opposite signs. -----------------------------! if (abs(fun-funa) < 100.*toler*tempa) then delta = 100.*toler*delta else delta = max(abs(funa * (tempz-tempa)/(fun-funa)),100.*toler*tempa) end if + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! Try guesses on both sides of the first guess, increasingly further away ! + ! until we spot a good guess. ! + !---------------------------------------------------------------------------------! tempz = tempa + delta zside = .false. zgssloop: do itb=1,maxfpo tempz = tempa + real((-1)**itb * (itb+3)/2) * delta funz = esif(tempz) - pvap - zside = funa*funz < 0 + zside = funa*funz < 0.0 if (zside) exit zgssloop end do zgssloop if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempa=',tempa,'funa=',funa - write (unit=*,fmt='(2(a,1x,es14.7))') 'tempz=',tempz,'func=',funz - call abort_run('Failed finding the second guess for regula falsi' & - ,'tsif','therm_lib.f90') + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the second guess:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' + call abort_run ('Failed finding the second guess for regula falsi' & + ,'tsif','therm_lib.f90') end if end if @@ -892,36 +1441,53 @@ real function tsif(pvap) tsif = (funz*tempa-funa*tempz)/(funz-funa) !---------------------------------------------------------------------------------! - ! Now that we updated the guess, check whether they are really close. If so, ! + ! Now that we updated the guess, check whether they are really close. If so, ! ! it converged, I can use this as my guess. ! !---------------------------------------------------------------------------------! converged = abs(tsif-tempa) < toler * tsif if (converged) exit bisloop + !---------------------------------------------------------------------------------! - !------ Finding the new function -------------------------------------------------! + !------ Find the new function evaluation. ----------------------------------------! fun = esif(tsif) - pvap + !---------------------------------------------------------------------------------! - !------ Defining my new interval based on the intermediate value theorem. --------! + + !------ Define the new interval based on the intermediate value theorem. ---------! if (fun*funa < 0. ) then tempz = tsif funz = fun - !----- If we are updating zside again, modify aside (Illinois method) ---------! + !----- If we are updating zside again, modify aside (Illinois method). --------! if (zside) funa=funa * 0.5 - !----- We just updated zside, setting zside to true. --------------------------! + !----- We have just updated zside, so we set zside to true. -------------------! zside = .true. else tempa = tsif funa = fun - !----- If we are updating aside again, modify aside (Illinois method) ---------! + !----- If we are updating aside again, modify aside (Illinois method). --------! if (.not. zside) funz=funz * 0.5 - !----- We just updated aside, setting aside to true. --------------------------! + !----- We have just updated aside, so we set zside to false. ------------------! zside = .false. end if end do bisloop if (.not.converged) then - call abort_run('Temperature didn''t converge, giving up!!!' & - ,'tsif','therm_lib.f90') + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' Failed finding the solution:' + write (unit=*,fmt='(a)') '------------------------------------------' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + pvap =',pvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Output: ' + write (unit=*,fmt='(a,1x,es14.7)') ' + tempa =',tempa + write (unit=*,fmt='(a,1x,es14.7)') ' + funa =',funa + write (unit=*,fmt='(a,1x,es14.7)') ' + tempz =',tempz + write (unit=*,fmt='(a,1x,es14.7)') ' + func =',funz + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') '------------------------------------------' + call abort_run ('Temperature didn''t converge, we give up!!!' & + ,'tsif','therm_lib.f90') end if return @@ -939,30 +1505,41 @@ end function tsif ! This function calculates the temperature from the ice or liquid mixing ratio. ! ! This is truly the inverse of eslf and esif. ! !---------------------------------------------------------------------------------------! - real function tslif(pvap,useice) - use rconstants, only: es3ple,alvl,alvi + real(kind=4) function tslif(pvap,useice) + use rconstants , only : es3ple ! ! intent(in) implicit none - real , intent(in) :: pvap - logical, intent(in), optional :: useice - logical :: brrr_cold - + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: pvap ! Vapour pressure [ Pa] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] + !----- Local variables. -------------------------------------------------------------! + logical :: frozen ! Will use ice thermodynamics [ T|F] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! - ! Since pvap is a function of temperature only, we can check the triple point ! + ! Since pvap is a function of temperature only, we can check the triple point ! ! from the saturation at the triple point, like what we would do for temperature. ! !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. pvap < es3ple + frozen = useice .and. pvap < es3ple else - brrr_cold = bulk_on .and. pvap < es3ple + frozen = bulk_on .and. pvap < es3ple end if + !------------------------------------------------------------------------------------! - if (brrr_cold) then + !------------------------------------------------------------------------------------! + ! Call the function depending on whether we should use ice. ! + !------------------------------------------------------------------------------------! + if (frozen) then tslif = tsif(pvap) else tslif = tslf(pvap) end if + !------------------------------------------------------------------------------------! return end function tslif @@ -977,19 +1554,34 @@ end function tslif !=======================================================================================! !=======================================================================================! ! This fucntion computes the dew point temperature given the pressure and vapour ! - ! mixing ratio. THIS IS DEWPOINT ONLY, WHICH MEANS THAT IT WILL IGNORE ICE EFFECT. For ! - ! a full, triple-point dependent routine use DEWFROSTPOINT ! + ! mixing ratio. THIS IS DEW POINT ONLY, WHICH MEANS THAT IT WILL IGNORE ICE EFFECT. For ! + ! a full, triple-point dependent routine use DEWFROSTPOINT. ! !---------------------------------------------------------------------------------------! - real function dewpoint(pres,rsat) - use rconstants, only: ep,toodry - + real(kind=4) function dewpoint(pres,rsat) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real, intent(in) :: pres, rsat - real :: rsatoff, pvsat - + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: rsatoff ! Non-singular saturation mixing ratio [ kg/kg] + real(kind=4) :: pvsat ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- Make sure mixing ratio is positive. ------------------------------------------! rsatoff = max(toodry,rsat) - pvsat = pres*rsatoff / (ep + rsatoff) + !------------------------------------------------------------------------------------! + + + !----- Find the saturation vapour pressure. -----------------------------------------! + pvsat = pres * rsatoff / (ep + rsatoff) + !------------------------------------------------------------------------------------! + + !----- Dew point is going to be the saturation temperature. -------------------------! dewpoint = tslf(pvsat) + !------------------------------------------------------------------------------------! return end function dewpoint @@ -1004,19 +1596,34 @@ end function dewpoint !=======================================================================================! !=======================================================================================! ! This fucntion computes the frost point temperature given the pressure and vapour ! - ! mixing ratio. THIS IS FROSTPOINT ONLY, WHICH MEANS THAT IT WILL IGNORE LIQUID EFFECT. ! - ! For a full, triple-point dependent routine use DEWFROSTPOINT ! + ! mixing ratio. THIS IS FROST POINT ONLY, WHICH MEANS THAT IT WILL IGNORE LIQUID ! + ! EFFECT. For a full, triple-point dependent routine use DEWFROSTPOINT. ! !---------------------------------------------------------------------------------------! - real function frostpoint(pres,rsat) - use rconstants, only: ep,toodry - + real(kind=4) function frostpoint(pres,rsat) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real, intent(in) :: pres, rsat - real :: rsatoff, pvsat - + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Local variables for iterative method. ----------------------------------------! + real(kind=4) :: rsatoff ! Non-singular saturation mixing ratio [ kg/kg] + real(kind=4) :: pvsat ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- Make sure mixing ratio is positive. ------------------------------------------! rsatoff = max(toodry,rsat) + !------------------------------------------------------------------------------------! + + + !----- Find the saturation vapour pressure. -----------------------------------------! pvsat = pres*rsatoff / (ep + rsatoff) + !------------------------------------------------------------------------------------! + + !----- Frost point is going to be the saturation temperature. -----------------------! frostpoint = tsif(pvsat) + !------------------------------------------------------------------------------------! return end function frostpoint @@ -1034,21 +1641,37 @@ end function frostpoint ! vapour mixing ratio. This will check whether the vapour pressure is above or below ! ! the triple point vapour pressure, finding dewpoint or frostpoint accordingly. ! !---------------------------------------------------------------------------------------! - real function dewfrostpoint(pres,rsat,useice) - use rconstants, only: ep,toodry + real(kind=4) function dewfrostpoint(pres,rsat,useice) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real , intent(in) :: pres, rsat - logical, intent(in), optional :: useice - real :: rsatoff, pvsat + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: rsatoff ! Non-singular sat. mix. rat. [ kg/kg] + real(kind=4) :: pvsat ! Saturation vapour pressure [ Pa] + !------------------------------------------------------------------------------------! + + + !----- Make sure mixing ratio is positive. ------------------------------------------! + rsatoff = max(toodry,rsat) + !------------------------------------------------------------------------------------! - rsatoff = max(toodry,rsat) + !----- Find the saturation vapour pressure. -----------------------------------------! pvsat = pres*rsatoff / (ep + rsatoff) + !------------------------------------------------------------------------------------! + + !----- Dew (frost) point is going to be the saturation temperature. -----------------! if (present(useice)) then dewfrostpoint = tslif(pvsat,useice) else dewfrostpoint = tslif(pvsat) end if + !------------------------------------------------------------------------------------! return end function dewfrostpoint !=======================================================================================! @@ -1061,28 +1684,52 @@ end function dewfrostpoint !=======================================================================================! !=======================================================================================! - ! This function computes the vapour mixing ratio based on the pressure [Pa], tem- ! - ! perature [K] and relative humidity [fraction]. IT ALWAYS ASSUME THAT RELATIVE HUMI- ! - ! DITY IS WITH RESPECT TO THE LIQUID PHASE. ptrh2rvapil checks which one to use ! - ! depending on whether temperature is more or less than the triple point. ! + ! This function computes the vapour mixing ratio (or specific humidity) based on ! + ! the pressure [Pa], temperature [K] and relative humidity [fraction]. IT ALWAYS ! + ! ASSUMES THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE LIQUID PHASE. Ptrh2rvapil ! + ! checks which one to use depending on whether temperature is more or less than the ! + ! triple point. ! !---------------------------------------------------------------------------------------! - real function ptrh2rvapl(relh,pres,temp) - use rconstants, only: ep,toodry - + real(kind=4) function ptrh2rvapl(relh,pres,temp,out_shv) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real , intent(in) :: relh, pres, temp - real :: rsath, relhh - rsath = max(toodry,rslf(pres,temp)) + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: relh ! Relative humidity [ --] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + logical , intent(in) :: out_shv ! Output is specific humidity [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: pvap ! Vapour pressure [ Pa] + real(kind=4) :: relhh ! Bounded relative humidity [ --] + !------------------------------------------------------------------------------------! + + + + !---- Make sure relative humidity is bounded. ---------------------------------------! relhh = min(1.,max(0.,relh)) + !------------------------------------------------------------------------------------! - if (newthermo) then - !----- Considering that Rel.Hum. is based on vapour pressure ---------------------! - ptrh2rvapl = max(toodry,ep * relhh * rsath / (ep + (1.-relhh)*rsath)) + + !---- Find the vapour pressure. -----------------------------------------------------! + pvap = relhh * eslf(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Convert the output to the sought humidity variable. ! + !------------------------------------------------------------------------------------! + if (out_shv) then + !----- Specific humidity. --------------------------------------------------------! + ptrh2rvapl = max(toodry, ep * pvap / (pres - (1.0 - ep) * pvap)) + !---------------------------------------------------------------------------------! else - !----- Original RAMS way to compute mixing ratio ---------------------------------! - ptrh2rvapl = max(toodry,relhh*rsath) + !----- Mixing ratio. -------------------------------------------------------------! + ptrh2rvapl = max(toodry, ep * pvap / (pres - pvap)) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return end function ptrh2rvapl @@ -1096,28 +1743,52 @@ end function ptrh2rvapl !=======================================================================================! !=======================================================================================! - ! This function computes the vapour mixing ratio based on the pressure [Pa], tem- ! - ! perature [K] and relative humidity [fraction]. IT ALWAYS ASSUME THAT RELATIVE HUMI- ! - ! DITY IS WITH RESPECT TO THE ICE PHASE. ptrh2rvapil checks which one to use depending ! - ! on whether temperature is more or less than the triple point. ! + ! This function computes the vapour mixing ratio (or specific humidity) based on ! + ! the pressure [Pa], temperature [K] and relative humidity [fraction]. IT ALWAYS ! + ! ASSUMES THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE ICE PHASE. Ptrh2rvapil ! + ! checks which one to use depending on whether temperature is more or less than the ! + ! triple point. ! !---------------------------------------------------------------------------------------! - real function ptrh2rvapi(relh,pres,temp) - use rconstants, only: ep,toodry - + real(kind=4) function ptrh2rvapi(relh,pres,temp,out_shv) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none - real , intent(in) :: relh, pres, temp - real :: rsath, relhh - rsath = max(toodry,rsif(pres,temp)) + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: relh ! Relative humidity [ --] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + logical , intent(in) :: out_shv ! Output is specific humidity [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: pvap ! Vapour pressure [ Pa] + real(kind=4) :: relhh ! Bounded relative humidity [ --] + !------------------------------------------------------------------------------------! + + + + !---- Make sure relative humidity is bounded. ---------------------------------------! relhh = min(1.,max(0.,relh)) + !------------------------------------------------------------------------------------! - if (newthermo) then - !----- Considering that Rel.Hum. is based on vapour pressure ---------------------! - ptrh2rvapi = max(toodry,ep * relhh * rsath / (ep + (1.-relhh)*rsath)) + + !---- Find the vapour pressure. -----------------------------------------------------! + pvap = relhh * esif(temp) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Convert the output to the sought humidity variable. ! + !------------------------------------------------------------------------------------! + if (out_shv) then + !----- Specific humidity. --------------------------------------------------------! + ptrh2rvapi = max(toodry, ep * pvap / (pres - (1.0 - ep) * pvap)) + !---------------------------------------------------------------------------------! else - !----- Original RAMS way to compute mixing ratio ---------------------------------! - ptrh2rvapi = max(toodry,relhh*rsath) + !----- Mixing ratio. -------------------------------------------------------------! + ptrh2rvapi = max(toodry, ep * pvap / (pres - pvap)) + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return end function ptrh2rvapi @@ -1131,36 +1802,67 @@ end function ptrh2rvapi !=======================================================================================! !=======================================================================================! - ! This function computes the vapour mixing ratio based on the pressure [Pa], tem- ! - ! perature [K] and relative humidity [fraction]. It will check the temperature to ! - ! decide between ice or liquid saturation and whether ice should be considered. ! + ! This function computes the vapour mixing ratio based (or specific humidity) based ! + ! on the pressure [Pa], temperature [K] and relative humidity [fraction]. It checks ! + ! the temperature to decide between ice or liquid saturation. ! !---------------------------------------------------------------------------------------! - real function ptrh2rvapil(relh,pres,temp,useice) - use rconstants, only: ep,toodry,t3ple + real(kind=4) function ptrh2rvapil(relh,pres,temp,out_shv,useice) + use rconstants , only : ep & ! intent(in) + , toodry & ! intent(in) + , t3ple ! ! intent(in) implicit none - real , intent(in) :: relh, pres, temp - logical, intent(in), optional :: useice - real :: rsath, relhh - logical :: brrr_cold + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: relh ! Relative humidity [ --] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + logical , intent(in) :: out_shv ! Output is specific humidity [ T|F] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: pvap ! Vapour pressure [ Pa] + real(kind=4) :: relhh ! Bounded relative humidity [ --] + logical :: frozen ! Will use ice thermodynamics [ T|F] + !------------------------------------------------------------------------------------! + - !----- Checking whether I use the user or the default check for ice saturation. -----! + !----- Check whether to use the user's or the default flag for ice saturation. ------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple end if + !------------------------------------------------------------------------------------! + - if (brrr_cold) then - rsath = max(toodry,rsif(pres,temp)) + + !---- Make sure relative humidity is bounded. ---------------------------------------! + relhh = min(1.,max(0.,relh)) + !------------------------------------------------------------------------------------! + + + !---- Find the vapour pressure (ice or liquid, depending on the value of frozen). ---! + if (frozen) then + pvap = relhh * esif(temp) else - rsath = max(toodry,rslf(pres,temp)) + pvap = relhh * eslf(temp) end if + !------------------------------------------------------------------------------------! - relhh = min(1.,max(0.,relh)) - - ptrh2rvapil = max(toodry,ep * relhh * rsath / (ep + (1.-relhh)*rsath)) + !------------------------------------------------------------------------------------! + ! Convert the output to the sought humidity variable. ! + !------------------------------------------------------------------------------------! + if (out_shv) then + !----- Specific humidity. --------------------------------------------------------! + ptrh2rvapil = max(toodry, ep * pvap / (pres - (1.0 - ep) * pvap)) + !---------------------------------------------------------------------------------! + else + !----- Mixing ratio. -------------------------------------------------------------! + ptrh2rvapil = max(toodry, ep * pvap / (pres - pvap)) + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! return end function ptrh2rvapil !=======================================================================================! @@ -1174,32 +1876,51 @@ end function ptrh2rvapil !=======================================================================================! !=======================================================================================! ! This function computes the relative humidity [fraction] based on pressure, tem- ! - ! perature, and vapour mixing ratio. Two important points: ! + ! perature, and vapour mixing ratio (or specific humidity). Two important points: ! ! 1. IT ALWAYS ASSUME THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE LIQUID PHASE. ! ! If you want to switch between ice and liquid, use rehuil instead. ! ! 2. IT DOESN'T PREVENT SUPERSATURATION TO OCCUR. This is because this subroutine is ! ! also used in the microphysics, where supersaturation does happen and needs to be ! ! accounted. ! !---------------------------------------------------------------------------------------! - real function rehul(pres,temp,rvap) - use rconstants, only: ep,toodry + real(kind=4) function rehul(pres,temp,humi,is_shv) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: pres ! Air pressure [ Pa] - real , intent(in) :: temp ! Temperature [ K] - real , intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] + real(kind=4), intent(in) :: pres ! Air pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: humi ! Humidity [ kg/kg] + logical , intent(in) :: is_shv ! Input humidity is specific humidity [ T|F] !----- Local variables --------------------------------------------------------------! - real :: rvapsat ! Saturation mixing ratio [ kg/kg] + real(kind=4) :: shv ! Specific humidity [ kg/kg] + real(kind=4) :: pvap ! Vapour pressure [ Pa] + real(kind=4) :: psat ! Saturation vapour pressure [ Pa] !------------------------------------------------------------------------------------! - rvapsat = max(toodry,rslf(pres,temp)) - if (newthermo) then - !----- This is based on relative humidity being defined with vapour pressure -----! - rehul = max(0.,rvap*(ep+rvapsat)/(rvapsat*(ep+rvap))) + + !---- Make sure that we have specific humidity. -------------------------------------! + if (is_shv) then + shv = max(toodry,humi) else - !----- Original formula used by RAMS ---------------------------------------------! - rehul = max(0.,rvap/rvapsat) + shv = max(toodry,humi) / ( 1.0 + max(toodry,humi) ) end if + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the vapour pressure and the saturation vapour pressure. ! + !------------------------------------------------------------------------------------! + pvap = ( pres * shv ) / ( ep + (1.0 - ep) * shv ) + psat = eslf (temp) + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Find the relative humidity. ! + !------------------------------------------------------------------------------------! + rehul = max(0. ,pvap / psat) + !------------------------------------------------------------------------------------! + return end function rehul !=======================================================================================! @@ -1213,38 +1934,57 @@ end function rehul !=======================================================================================! !=======================================================================================! ! This function computes the relative humidity [fraction] based on pressure, tem- ! - ! perature, and vapour mixing ratio. Two important points: ! + ! perature, and vapour mixing ratio (or specific humidity). Two important points: ! ! 1. IT ALWAYS ASSUME THAT RELATIVE HUMIDITY IS WITH RESPECT TO THE ICE PHASE. ! ! If you want to switch between ice and liquid, use rehuil instead. ! ! 2. IT DOESN'T PREVENT SUPERSATURATION TO OCCUR. This is because this subroutine is ! ! also used in the microphysics, where supersaturation does happen and needs to be ! ! accounted. ! !---------------------------------------------------------------------------------------! - real function rehui(pres,temp,rvap) - use rconstants, only: ep,toodry + real(kind=4) function rehui(pres,temp,humi,is_shv) + use rconstants , only : ep & ! intent(in) + , toodry ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: pres ! Air pressure [ Pa] - real , intent(in) :: temp ! Temperature [ K] - real , intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] + real(kind=4), intent(in) :: pres ! Air pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: humi ! Humidity [ kg/kg] + logical , intent(in) :: is_shv ! Input humidity is specific humidity [ T|F] !----- Local variables --------------------------------------------------------------! - real :: rvapsat ! Saturation mixing ratio [ kg/kg] + real(kind=4) :: shv ! Specific humidity [ kg/kg] + real(kind=4) :: pvap ! Vapour pressure [ Pa] + real(kind=4) :: psat ! Saturation vapour pressure [ Pa] !------------------------------------------------------------------------------------! - rvapsat = max(toodry,rsif(pres,temp)) - if (newthermo) then - !----- This is based on relative humidity being defined with vapour pressure -----! - rehui = max(0.,rvap*(ep+rvapsat)/(rvapsat*(ep+rvap))) + + !---- Make sure that we have specific humidity. -------------------------------------! + if (is_shv) then + shv = max(toodry,humi) else - !----- Original formula used by RAMS ---------------------------------------------! - rehui = max(0.,rvap/rvapsat) + shv = max(toodry,humi) / ( 1.0 + max(toodry,humi) ) end if - return - end function rehui - !=======================================================================================! - !=======================================================================================! - - + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the vapour pressure and the saturation vapour pressure. ! + !------------------------------------------------------------------------------------! + pvap = ( pres * shv ) / ( ep + (1.0 - ep) * shv ) + psat = esif (temp) + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Find the relative humidity. ! + !------------------------------------------------------------------------------------! + rehui = max(0. ,pvap / psat) + !------------------------------------------------------------------------------------! + + return + end function rehui + !=======================================================================================! + !=======================================================================================! + + @@ -1252,7 +1992,7 @@ end function rehui !=======================================================================================! !=======================================================================================! ! This function computes the relative humidity [fraction] based on pressure, tem- ! - ! perature, and vapour mixing ratio. Two important points: ! + ! perature, and vapour mixing ratio (or specific humidity). Two important points: ! ! 1. It may consider whether the temperature is above or below the freezing point ! ! to choose which saturation to use. It is possible to explicitly force not to use ! ! ice in case level is 2 or if you have reasons not to use ice (e.g. reading data ! @@ -1261,33 +2001,62 @@ end function rehui ! also used in the microphysics, where supersaturation does happen and needs to be ! ! accounted. ! !---------------------------------------------------------------------------------------! - real function rehuil(pres,temp,rvap,useice) - use rconstants, only: t3ple + real(kind=4) function rehuil(pres,temp,humi,is_shv,useice) + use rconstants , only : t3ple & ! intent(in) + , ep & ! intent(in) + , toodry ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: pres ! Air pressure [ Pa] - real , intent(in) :: temp ! Temperature [ K] - real , intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] - logical, intent(in), optional :: useice ! Should I consider ice? [ T|F] + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Air pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: humi ! Humidity [ kg/kg] + logical , intent(in) :: is_shv ! Input is specific humidity [ T|F] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May use ice thermodynamics [ T|F] !----- Local variables --------------------------------------------------------------! - real :: rvapsat ! Saturation mixing ratio [ kg/kg] - logical :: brrr_cold ! I will use ice saturation now [ T|F] + real(kind=4) :: shv ! Specific humidity [ kg/kg] + real(kind=4) :: pvap ! Vapour pressure [ Pa] + real(kind=4) :: psat ! Saturation vapour pressure [ Pa] + logical :: frozen ! Will use ice saturation now [ T|F] !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! - ! Checking whether I should go with ice or liquid saturation. ! + ! Check whether we should use ice or liquid saturation. ! !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice .and. temp < t3ple + frozen = useice .and. temp < t3ple else - brrr_cold = bulk_on .and. temp < t3ple + frozen = bulk_on .and. temp < t3ple + end if + !------------------------------------------------------------------------------------! + + + !---- Make sure that we have specific humidity. -------------------------------------! + if (is_shv) then + shv = max(toodry,humi) + else + shv = max(toodry,humi) / ( 1.0 + max(toodry,humi) ) end if + !------------------------------------------------------------------------------------! + - if (brrr_cold) then - rehuil = rehui(pres,temp,rvap) + !------------------------------------------------------------------------------------! + ! Find the vapour pressure and the saturation vapour pressure. ! + !------------------------------------------------------------------------------------! + pvap = ( pres * shv ) / ( ep + (1.0 - ep) * shv ) + if (frozen) then + psat = esif (temp) else - rehuil = rehul(pres,temp,rvap) + psat = esif (temp) end if + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Find the relative humidity. ! + !------------------------------------------------------------------------------------! + rehuil = max(0. ,pvap / psat) + !------------------------------------------------------------------------------------! return end function rehuil @@ -1307,23 +2076,33 @@ end function rehuil ! 2. This can be used for virtual potential temperature, just give potential tempera- ! ! ture instead of temperature. ! !---------------------------------------------------------------------------------------! - real function tv2temp(tvir,rvap,rtot) - use rconstants, only: epi + real(kind=4) function tv2temp(tvir,rvap,rtot) + use rconstants , only : epi ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: tvir ! Virtual temperature [ K] - real, intent(in) :: rvap ! Vapour mixing ratio [kg/kg] - real, intent(in), optional :: rtot ! Total mixing ratio [kg/kg] - !----- Local variable ---------------------------------------------------------------! - real :: rtothere ! Internal rtot, to deal with optional [kg/kg] + real(kind=4), intent(in) :: tvir ! Virtual temperature [ K] + real(kind=4), intent(in) :: rvap ! Vapour mixing ratio [kg/kg] + real(kind=4), intent(in), optional :: rtot ! Total mixing ratio [kg/kg] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: rtothere ! Total or vapour mixing ratio [kg/kg] + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Prefer using total mixing ratio, but if it isn't provided, then use vapour ! + ! as total (no condensation). ! + !------------------------------------------------------------------------------------! if (present(rtot)) then rtothere = rtot else rtothere = rvap end if + !------------------------------------------------------------------------------------! + + !----- Convert using a generalised function. ----------------------------------------! tv2temp = tvir * (1. + rtothere) / (1. + epi*rvap) + !------------------------------------------------------------------------------------! return end function tv2temp @@ -1343,23 +2122,33 @@ end function tv2temp ! 2. This can be used for virtual potential temperature, just give potential tempera- ! ! ture instead of temperature. ! !---------------------------------------------------------------------------------------! - real function virtt(temp,rvap,rtot) - use rconstants, only: epi + real(kind=4) function virtt(temp,rvap,rtot) + use rconstants , only: epi ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: rvap ! Vapour mixing ratio [kg/kg] - real, intent(in), optional :: rtot ! Total mixing ratio [kg/kg] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rvap ! Vapour mixing ratio [kg/kg] + real(kind=4), intent(in), optional :: rtot ! Total mixing ratio [kg/kg] !----- Local variable ---------------------------------------------------------------! - real :: rtothere ! Internal rtot, to deal with optional [kg/kg] + real(kind=4) :: rtothere ! Total or vapour mixing ratio [kg/kg] + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Prefer using total mixing ratio, but if it isn't provided, then use vapour ! + ! as total (no condensation). ! + !------------------------------------------------------------------------------------! if (present(rtot)) then rtothere = rtot else rtothere = rvap end if + !------------------------------------------------------------------------------------! + + !----- Convert using a generalised function. ----------------------------------------! virtt = temp * (1. + epi * rvap) / (1. + rtothere) + !------------------------------------------------------------------------------------! return end function virtt @@ -1377,24 +2166,34 @@ end function virtt ! gas law. The condensed phase will be taken into account if the user provided both ! ! the vapour and the total mixing ratios. ! !---------------------------------------------------------------------------------------! - real function idealdens(pres,temp,rvap,rtot) - use rconstants, only: rdry + real(kind=4) function idealdens(pres,temp,rvap,rtot) + use rconstants , only : rdry ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: rvap ! Vapour mixing ratio [kg/kg] - real, intent(in), optional :: rtot ! Total mixing ratio [kg/kg] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] + real(kind=4), intent(in), optional :: rtot ! Total mixing ratio [ kg/kg] !----- Local variable ---------------------------------------------------------------! - real :: tvir ! Virtual temperature [ K] + real(kind=4) :: tvir ! Virtual temperature [ K] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Prefer using total mixing ratio, but if it isn't provided, then use vapour ! + ! as total (no condensation). ! !------------------------------------------------------------------------------------! if (present(rtot)) then tvir = virtt(temp,rvap,rtot) else tvir = virtt(temp,rvap) end if + !------------------------------------------------------------------------------------! + + !----- Convert using the definition of virtual temperature. -------------------------! idealdens = pres / (rdry * tvir) + !------------------------------------------------------------------------------------! return end function idealdens @@ -1412,26 +2211,35 @@ end function idealdens ! gas law. The only difference between this function and the one above is that here we ! ! provide vapour and total specific mass (specific humidity) instead of mixing ratio. ! !---------------------------------------------------------------------------------------! - real function idealdenssh(pres,temp,qvpr,qtot) - use rconstants, only : rdry & ! intent(in) - , epi ! ! intent(in) + real(kind=4) function idealdenssh(pres,temp,qvpr,qtot) + use rconstants , only : rdry & ! intent(in) + , epi ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: qvpr ! Vapour specific mass [kg/kg] - real, intent(in), optional :: qtot ! Total water specific mass [kg/kg] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: qvpr ! Vapour specific mass [ kg/kg] + real(kind=4), intent(in), optional :: qtot ! Total water specific mass [ kg/kg] !----- Local variables. -------------------------------------------------------------! - real :: qall ! Either qtot or qvpr... [kg/kg] + real(kind=4) :: qall ! Either qtot or qvpr... [ kg/kg] !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! + ! Prefer using total specific humidity, but if it isn't provided, then use ! + ! vapour phase as the total (no condensation). ! + !------------------------------------------------------------------------------------! if (present(qtot)) then qall = qtot else qall = qvpr end if + !------------------------------------------------------------------------------------! + + !----- Convert using a generalised function. ----------------------------------------! idealdenssh = pres / (rdry * temp * (1. - qall + epi * qvpr)) + !------------------------------------------------------------------------------------! return end function idealdenssh @@ -1446,27 +2254,28 @@ end function idealdenssh !=======================================================================================! !=======================================================================================! ! This function computes reduces the pressure from the reference height to the ! - ! canopy height by assuming hydrostatic equilibrium. ! - !---------------------------------------------------------------------------------------! - real function reducedpress(pres,thetaref,shvref,zref,thetacan,shvcan,zcan) - use rconstants, only : epim1 & ! intent(in) - , p00k & ! intent(in) - , rocp & ! intent(in) - , cpor & ! intent(in) - , cp & ! intent(in) - , grav ! ! intent(in) + ! canopy height by assuming hydrostatic equilibrium. For simplicity, we assume that ! + ! R and cp are constants (in reality they are dependent on humidity). ! + !---------------------------------------------------------------------------------------! + real(kind=4) function reducedpress(pres,thetaref,shvref,zref,thetacan,shvcan,zcan) + use rconstants , only : epim1 & ! intent(in) + , p00k & ! intent(in) + , rocp & ! intent(in) + , cpor & ! intent(in) + , cpdry & ! intent(in) + , grav ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: thetaref ! Potential temperature [ K] - real, intent(in) :: shvref ! Vapour specific mass [ kg/kg] - real, intent(in) :: zref ! Height at reference level [ m] - real, intent(in) :: thetacan ! Potential temperature [ K] - real, intent(in) :: shvcan ! Vapour specific mass [ kg/kg] - real, intent(in) :: zcan ! Height at canopy level [ m] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: thetaref ! Potential temperature [ K] + real(kind=4), intent(in) :: shvref ! Vapour specific mass [ kg/kg] + real(kind=4), intent(in) :: zref ! Height at reference level [ m] + real(kind=4), intent(in) :: thetacan ! Potential temperature [ K] + real(kind=4), intent(in) :: shvcan ! Vapour specific mass [ kg/kg] + real(kind=4), intent(in) :: zcan ! Height at canopy level [ m] !------Local variables. -------------------------------------------------------------! - real :: pinc ! Pressure increment [ Pa^(R/cp)] - real :: thvbar ! Average virtual pot. temper. [ K] + real(kind=4) :: pinc ! Pressure increment [ Pa^R/cp] + real(kind=4) :: thvbar ! Average virtual pot. temperature [ K] !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! @@ -1474,12 +2283,19 @@ real function reducedpress(pres,thetaref,shvref,zref,thetacan,shvcan,zcan) ! top and the reference level. ! !------------------------------------------------------------------------------------! thvbar = 0.5 * (thetaref * (1. + epim1 * shvref) + thetacan * (1. + epim1 * shvcan)) + !------------------------------------------------------------------------------------! + + !----- Then, we find the pressure gradient scale. -----------------------------------! - pinc = grav * p00k * (zref - zcan) / (cp * thvbar) + pinc = grav * p00k * (zref - zcan) / (cpdry * thvbar) + !------------------------------------------------------------------------------------! + + !----- And we can find the reduced pressure. ----------------------------------------! reducedpress = (pres**rocp + pinc ) ** cpor + !------------------------------------------------------------------------------------! return end function reducedpress @@ -1491,50 +2307,31 @@ end function reducedpress + !=======================================================================================! !=======================================================================================! - ! This function computes the enthalpy given the pressure, temperature, vapour ! - ! specific humidity, and height. Currently it doesn't compute mixed phase air, but ! - ! adding it should be straight forward (finding the inverse is another story...). ! + ! This function computes the Exner function [J/kg/K], given the pressure. It ! + ! assumes for simplicity that R and Cp are constants and equal to the dry air values. ! !---------------------------------------------------------------------------------------! - real function ptqz2enthalpy(pres,temp,qvpr,zref) - use rconstants, only : ep & ! intent(in) - , grav & ! intent(in) - , t3ple & ! intent(in) - , eta3ple & ! intent(in) - , cimcp & ! intent(in) - , clmcp & ! intent(in) - , cp & ! intent(in) - , alvi ! ! intent(in) + real(kind=4) function press2exner(pres) + use rconstants , only : p00i & ! intent(in) + , cpdry & ! intent(in) + , rocp ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: qvpr ! Vapour specific mass [ kg/kg] - real, intent(in) :: zref ! Reference height [ m] - !------Local variables. -------------------------------------------------------------! - real :: tequ ! Dew-frost temperature [ K] - real :: pequ ! Equlibrium vapour pressure [ Pa] + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: pres ! Pressure [ Pa] !------------------------------------------------------------------------------------! - !----- First, we find the equilibrium vapour pressure and dew/frost point. ----------! - pequ = pres * qvpr / (ep + (1. - ep) * qvpr) - tequ = tslif(pequ) !------------------------------------------------------------------------------------! - ! Then, based on dew/frost point, we compute the enthalpy. This accounts whether ! - ! we would have to dew or frost formation if the temperature dropped to the ! - ! equilibrium point. Notice that if supersaturation exists, this will still give a ! - ! number that makes sense, similar to the internal energy of supercooled water. ! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + press2exner = cpdry * ( pres * p00i ) ** rocp !------------------------------------------------------------------------------------! - if (tequ <= t3ple) then - ptqz2enthalpy = cp * temp + qvpr * (cimcp * tequ + alvi ) + grav * zref - else - ptqz2enthalpy = cp * temp + qvpr * (clmcp * tequ + eta3ple) + grav * zref - end if return - end function ptqz2enthalpy + end function press2exner !=======================================================================================! !=======================================================================================! @@ -1543,52 +2340,32 @@ end function ptqz2enthalpy + !=======================================================================================! !=======================================================================================! - ! This function computes the temperature given the enthalpy, pressure, vapour ! - ! specific humidity, and reference height. Currently it doesn't compute mixed phase ! - ! air, but adding it wouldn't be horribly hard, though it would require some root ! - ! finding. ! + ! This function computes the pressure [Pa], given the Exner function. Like in the ! + ! function above, we also assume R and Cp to be constants and equal to the dry air ! + ! values. ! !---------------------------------------------------------------------------------------! - real function hpqz2temp(enthalpy,pres,qvpr,zref) - use rconstants, only : ep & ! intent(in) - , grav & ! intent(in) - , t3ple & ! intent(in) - , eta3ple & ! intent(in) - , cimcp & ! intent(in) - , clmcp & ! intent(in) - , cpi & ! intent(in) - , alvi ! ! intent(in) + real(kind=4) function exner2press(exner) + use rconstants , only : p00 & ! intent(in) + , cpdryi & ! intent(in) + , cpor ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: enthalpy ! Enthalpy... [ J/kg] - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: qvpr ! Vapour specific mass [ kg/kg] - real, intent(in) :: zref ! Reference height [ m] - !------Local variables. -------------------------------------------------------------! - real :: tequ ! Dew-frost temperature [ K] - real :: pequ ! Equlibrium vapour pressure [ Pa] + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: exner ! Exner function [ J/kg/K] !------------------------------------------------------------------------------------! - !----- First, we find the equilibrium vapour pressure and dew/frost point. ----------! - pequ = pres * qvpr / (ep + (1. - ep) * qvpr) - tequ = tslif(pequ) !------------------------------------------------------------------------------------! - ! Then, based on dew/frost point, we compute the temperature. This accounts ! - ! whether we would have to dew or frost formation if the temperature dropped to the ! - ! equilibrium point. Notice that if supersaturation exists, this will still give a ! - ! temperature that makes sense (but less than the dew/frost point), similar to the ! - ! internal energy of supercooled water. ! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + exner2press = p00 * ( exner * cpdryi ) ** cpor !------------------------------------------------------------------------------------! - if (tequ <= t3ple) then - hpqz2temp = cpi * (enthalpy - qvpr * (cimcp * tequ + alvi ) - grav * zref) - else - hpqz2temp = cpi * (enthalpy - qvpr * (clmcp * tequ + eta3ple) - grav * zref) - end if return - end function hpqz2temp + end function exner2press !=======================================================================================! !=======================================================================================! @@ -1597,31 +2374,31 @@ end function hpqz2temp + !=======================================================================================! !=======================================================================================! - ! This function finds the temperature given the potential temperature, density, and ! - ! specific humidity. This comes from a combination of the definition of potential ! - ! temperature and the ideal gas law, to eliminate pressure, when pressure is also ! - ! unknown. ! + ! This function computes the potential temperature [K], given the Exner function ! + ! and temperature. For simplicity we ignore the effects of humidity in R and cp and ! + ! use the dry air values instead. ! !---------------------------------------------------------------------------------------! - real(kind=4) function thrhsh2temp(theta,dens,qvpr) - use rconstants , only : cpocv & ! intent(in) - , p00i & ! intent(in) - , rdry & ! intent(in) - , epim1 & ! intent(in) - , rocv ! ! intent(in) + real(kind=4) function extemp2theta(exner,temp) + use rconstants , only : cpdry ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real(kind=4), intent(in) :: theta ! Potential temperature [ K] - real(kind=4), intent(in) :: dens ! Density [ Pa] - real(kind=4), intent(in) :: qvpr ! Specific humidity [ kg/kg] + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: exner ! Exner function [ J/kg/K] + real(kind=4), intent(in) :: temp ! Temperature [ K] !------------------------------------------------------------------------------------! - thrhsh2temp = theta ** cpocv & - * (p00i * dens * rdry * (1. + epim1 * qvpr)) ** rocv + + !------------------------------------------------------------------------------------! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + extemp2theta = cpdry * temp / exner + !------------------------------------------------------------------------------------! return - end function thrhsh2temp + end function extemp2theta !=======================================================================================! !=======================================================================================! @@ -1630,48 +2407,68 @@ end function thrhsh2temp + !=======================================================================================! !=======================================================================================! - ! This fucntion computes the ice liquid potential temperature given the Exner ! - ! function [J/kg/K], temperature [K], and liquid and ice mixing ratios [kg/kg]. ! + ! This function computes the temperature [K], given the Exner function and ! + ! potential temperature. We simplify the equations by assuming that R and Cp are ! + ! constants. ! !---------------------------------------------------------------------------------------! - real function theta_iceliq(exner,temp,rliq,rice) - use rconstants, only: alvl, alvi, cp, ttripoli, htripoli, htripolii + real(kind=4) function extheta2temp(exner,theta) + use rconstants , only : p00i & ! intent(in) + , cpdryi ! ! intent(in) + + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: exner ! Exner function [ J/kg/K] + real(kind=4), intent(in) :: theta ! Potential temperature [ K] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find potential temperature. ! + !------------------------------------------------------------------------------------! + extheta2temp = cpdryi * exner * theta + !------------------------------------------------------------------------------------! + + return + end function extheta2temp + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the specific (intensive) internal energy of water [J/kg], ! + ! given the temperature and liquid fraction. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function tl2uint(temp,fliq) + use rconstants , only : cice & ! intent(in) + , cliq & ! intent(in) + , tsupercool_liq ! ! intent(in) + implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: exner ! Exner function [J/kg/K] - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] - real, intent(in) :: rice ! Ice mixing ratio [ kg/kg] - !----- Local variables --------------------------------------------------------------! - real :: hh ! Enthalpy associated with sensible heat [ J/kg] - real :: qq ! Enthalpy associated with latent heat [ J/kg] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: fliq ! Fraction liquid water [ kg/kg] !------------------------------------------------------------------------------------! - !----- Finding the enthalpies -------------------------------------------------------! - hh = cp*temp - qq = alvl*rliq+alvi*rice - - if (newthermo) then - - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli) then - theta_iceliq = hh * exp(-qq/hh) / exner - else - theta_iceliq = hh * exp(-qq * htripolii) / exner - end if - else - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli) then - theta_iceliq = hh * hh / (exner * ( hh + qq)) - else - theta_iceliq = hh * htripoli / (exner * ( htripoli + qq)) - end if - end if + + + !------------------------------------------------------------------------------------! + ! Internal energy is given by the sum of internal energies of ice and liquid ! + ! phases. ! + !------------------------------------------------------------------------------------! + tl2uint = (1.0 - fliq) * cice * temp + fliq * cliq * (temp - tsupercool_liq) + !------------------------------------------------------------------------------------! return - end function theta_iceliq + end function tl2uint !=======================================================================================! !=======================================================================================! @@ -1680,82 +2477,94 @@ end function theta_iceliq + !=======================================================================================! !=======================================================================================! - ! This function computes the liquid potential temperature derivative with respect ! - ! to temperature, useful in iterative methods. ! + ! This function computes the extensive internal energy of water [J/m²] or [ J/m³], ! + ! given the temperature [K], the heat capacity of the "dry" part [J/m²/K] or [J/m³/K], ! + ! water mass [ kg/m²] or [ kg/m³], and liquid fraction [---]. ! !---------------------------------------------------------------------------------------! - real function dthetail_dt(condconst,thil,exner,pres,temp,rliq,ricein) - use rconstants, only: alvl, alvi, cp, ttripoli,htripoli,htripolii,t3ple + real(kind=4) function cmtl2uext(dryhcap,wmass,temp,fliq) + use rconstants , only : cice & ! intent(in) + , cliq & ! intent(in) + , tsupercool_liq ! ! intent(in) + + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: dryhcap ! Heat cap. of "dry" part [J/m²/K] or [J/m³/K] + real(kind=4), intent(in) :: wmass ! Water mass [ kg/m²] or [ kg/m³] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: fliq ! Liquid fraction (0-1) [ ---] + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Internal energy is given by the sum of internal energies of dry part, plus the ! + ! contribution of ice and liquid phases. ! + !------------------------------------------------------------------------------------! + cmtl2uext = dryhcap * temp + wmass * ( (1.0 - fliq) * cice * temp & + + fliq * cliq * (temp - tsupercool_liq) ) + !------------------------------------------------------------------------------------! + + return + end function cmtl2uext + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the specific enthalpy [J/kg] given the temperature and ! + ! humidity (either mixing ratio or specific humidity). If we assume that latent heat ! + ! of vaporisation is a linear function of temperature (equivalent to assume that ! + ! specific heats are constants and that the thermal expansion of liquids and solids are ! + ! negligible), then the saturation disappears and the enthalpy becomes a straight- ! + ! forward state function. In case we are accounting for the water exchange only ! + ! (latent heat), set the specific humidity to 1.0 and multiply the result by water mass ! + ! or water flux. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function tq2enthalpy(temp,humi,is_shv) + use rconstants , only : cpdry & ! intent(in) + , cph2o & ! intent(in) + , tsupercool_vap ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - logical, intent(in) :: condconst ! Condensation is constant? [ T|F] - real , intent(in) :: thil ! Ice liquid pot. temperature [ K] - real , intent(in) :: exner ! Exner function [J/kg/K] - real , intent(in) :: pres ! Pressure [ Pa] - real , intent(in) :: temp ! Temperature [ K] - real , intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] - real , intent(in), optional :: ricein ! Ice mixing ratio [ kg/kg] - !----- Local variables --------------------------------------------------------------! - real :: rice ! Ice mixing ratio or 0. [ kg/kg] - real :: ldrst ! L × d(rs)/dT × T [ J/kg] - real :: hh ! Sensible heat enthalpy [ J/kg] - real :: qq ! Latent heat enthalpy [ J/kg] - logical :: thereisice ! Is ice present [ ---] + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: humi ! Humidity (spec. hum. or mixing ratio) [ kg/kg] + logical , intent(in) :: is_shv ! Input humidity is specific humidity [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: shv ! Specific humidity [ kg/kg] !------------------------------------------------------------------------------------! - + + !------------------------------------------------------------------------------------! - ! Checking whether I should consider ice or not. ! + ! Copy specific humidity to shv. ! !------------------------------------------------------------------------------------! - thereisice = present(ricein) - - if (thereisice) then - rice=ricein - else - rice=0. - end if - - !----- No condensation, dthetail_dt is a constant -----------------------------------! - if (rliq+rice == 0.) then - dthetail_dt = thil/temp - return + if (is_shv) then + shv = humi else - hh = cp*temp !----- Sensible heat enthalpy - qq = alvl*rliq+alvi*rice !----- Latent heat enthalpy - !---------------------------------------------------------------------------------! - ! This is the term L×[d(rs)/dt]×T. L may be either the vapourisation or ! - ! sublimation latent heat, depending on the temperature and whether we are consi- ! - ! dering ice or not. Also, if condensation mixing ratio is constant, then this ! - ! term will be always zero. ! - !---------------------------------------------------------------------------------! - if (condconst) then - ldrst = 0. - elseif (thereisice .and. temp < t3ple) then - ldrst = alvi*rsifp(pres,temp)*temp - else - ldrst = alvl*rslfp(pres,temp)*temp - end if + shv = humi / (humi + 1.0) end if + !------------------------------------------------------------------------------------! - if (newthermo) then - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli) then - dthetail_dt = thil * (1. + (ldrst + qq)/hh) / temp - else - dthetail_dt = thil * (1. + ldrst*htripolii) / temp - end if - else - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli) then - dthetail_dt = thil * (1. + (ldrst + qq)/(hh+qq)) / temp - else - dthetail_dt = thil * (1. + ldrst/(htripoli + alvl*rliq)) / temp - end if - end if + + + !------------------------------------------------------------------------------------! + ! Enthalpy is the combination of dry and moist enthalpies, with the latter being ! + ! allowed to change phase. ! + !------------------------------------------------------------------------------------! + tq2enthalpy = (1.0 - shv) * cpdry * temp + shv * cph2o * (temp - tsupercool_vap) + !------------------------------------------------------------------------------------! return - end function dthetail_dt + end function tq2enthalpy !=======================================================================================! !=======================================================================================! @@ -1764,230 +2573,54 @@ end function dthetail_dt + !=======================================================================================! !=======================================================================================! - ! This function computes temperature from the ice-liquid water potential temperature ! - ! in Kelvin, Exner function in J/kg/K, and liquid and ice mixing ratios in kg/kg. ! - ! For now t1stguess is used only to decide whether I should use the complete case or ! - ! the 253 K to reduce the error on neglecting the changes on latent heat due to temper- ! - ! ature. ! + ! This function computes the temperature [K] given the specific enthalpy and ! + ! humidity. If we assume that latent heat of vaporisation is a linear function of ! + ! temperature (equivalent to assume that specific heats are constants and that the ! + ! thermal expansion of liquid and water are negligible), then the saturation disappears ! + ! and the enthalpy becomes a straightforward state function. In case you are looking ! + ! at water exchange only, set the specific humidity to 1.0 and multiply the result by ! + ! the water mass or water flux. ! !---------------------------------------------------------------------------------------! - real function thil2temp(thil,exner,pres,rliq,rice,t1stguess) - use rconstants, only: cp, cpi, alvl, alvi, t00, t3ple, ttripoli,htripolii,cpi4 + real(kind=4) function hq2temp(enthalpy,humi,is_shv) + use rconstants , only : cpdry & ! intent(in) + , cph2o & ! intent(in) + , tsupercool_vap ! ! intent(in) + implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: thil ! Ice-liquid water potential temperature [ K] - real, intent(in) :: exner ! Exner function [J/kg/K] - real, intent(in) :: pres ! Pressure [ Pa] - real, intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] - real, intent(in) :: rice ! Ice mixing ratio [ kg/kg] - real, intent(in) :: t1stguess ! 1st. guess for temperature [ K] - !----- Local variables for iterative method -----------------------------------------! - real :: deriv ! Function derivative - real :: fun ! Function for which we seek a root. - real :: funa ! Smallest guess function - real :: funz ! Largest guess function - real :: tempa ! Smallest guess (or previous guess in Newton) - real :: tempz ! Largest guess (or new guess in Newton) - real :: delta ! Aux. var to compute 2nd guess for bisection - integer :: itn,itb ! Iteration counter - logical :: converged ! Convergence handle - logical :: zside ! Flag to check for one-sided approach... - real :: til ! Ice liquid temperature [ K] + real(kind=4), intent(in) :: enthalpy ! Specific enthalpy [ J/kg] + real(kind=4), intent(in) :: humi ! Humidity (spec. hum. or mixing ratio) [ kg/kg] + logical , intent(in) :: is_shv ! Input humidity is specific humidity [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: shv ! Specific humidity [ kg/kg] !------------------------------------------------------------------------------------! - !----- 1st. of all, check whether there is condensation. If not, theta_il = theta ---! - if (rliq+rice == 0.) then - thil2temp = cpi * thil * exner - return - !----- If not, check whether we are using the old thermo or the new one -------------! - elseif (.not. newthermo) then - til = cpi * thil * exner - if (t1stguess > ttripoli) then - thil2temp = 0.5 * (til + sqrt(til * (til + cpi4 * (alvl*rliq + alvi*rice)))) - else - thil2temp = til * ( 1. + (alvl*rliq+alvi*rice) * htripolii) - end if - return + !------------------------------------------------------------------------------------! + ! Copy specific humidity to shv. ! + !------------------------------------------------------------------------------------! + if (is_shv) then + shv = humi + else + shv = humi / (humi + 1.0) end if !------------------------------------------------------------------------------------! - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,a,1x,f11.4,2(1x,a,1x,es12.5))') & - ! 'itn=',itn,'bisection=',.false.,'tempz=',tempz-t00 & - ! ,'fun=',fun,'deriv=',deriv - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - - converged = abs(tempa-tempz) < toler*tempz - !----- Converged, happy with that, return the average b/w the 2 previous guesses -! - if (fun == 0.) then - thil2temp = tempz - converged = .true. - return - elseif(converged) then - thil2temp = 0.5 * (tempa+tempz) - return - end if - end do newloop - !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! Enthalpy is the combination of dry and moist enthalpies, with the latter being ! + ! allowed to change phase. ! + !------------------------------------------------------------------------------------! + hq2temp = ( enthalpy + shv * cph2o * tsupercool_vap ) & + / ( (1.0 - shv) * cpdry + shv * cph2o ) !------------------------------------------------------------------------------------! - if (funa * fun < 0.) then - funz = fun - zside = .true. - else - if (abs(fun-funa) < toler*tempa) then - delta = 100.*toler*tempa - else - delta = max(abs(funa * (tempz-tempa)/(fun-funa)),100.*toler*tempa) - end if - tempz = tempa + delta - zside = .false. - zgssloop: do itb=1,maxfpo - tempz = tempa + real((-1)**itb * (itb+3)/2) * delta - funz = theta_iceliq(exner,tempz,rliq,rice) - thil - zside = funa*funz < 0 - if (zside) exit zgssloop - end do zgssloop - if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'thil =',thil ,'t1st=',t1stguess - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'exner=',exner,'pres=',pres - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'rliq =',rliq ,'rice=',rice - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempa=',tempa,'funa=',funa - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempz=',tempz,'funz=',funz - write (unit=*,fmt='(1(a,1x,es14.7,1x))') 'delta=',delta - call abort_run('Failed finding the second guess for regula falsi' & - ,'thil2temp','therm_lib.f90') - end if - end if - - - bisloop: do itb=itn,maxfpo - thil2temp = (funz*tempa-funa*tempz)/(funz-funa) - - !---------------------------------------------------------------------------------! - ! Now that we updated the guess, check whether they are really close. If so, ! - ! it converged, I can use this as my guess. ! - !---------------------------------------------------------------------------------! - converged = abs(thil2temp-tempa)< toler*thil2temp - if (converged) exit bisloop - - !------ Finding the new function -------------------------------------------------! - fun = theta_iceliq(exner,tempz,rliq,rice) - thil - - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,6(1x,a,1x,f11.4))') & - ! 'itn=',itb,'bisection=',.true. & - ! ,'temp=',thil2temp-t00,'tempa=',tempa-t00,'tempz=',tempz-t00 & - ! ,'fun=',fun,'funa=',funa,'funz=',funz - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - - !------ Defining my new interval based on the intermediate value theorem. --------! - if (fun*funa < 0. ) then - tempz = thil2temp - funz = fun - !----- If we are updating zside again, modify aside (Illinois method) ---------! - if (zside) funa=funa * 0.5 - !----- We just updated zside, setting zside to true. --------------------------! - zside = .true. - else - tempa = thil2temp - funa = fun - !----- If we are updating aside again, modify aside (Illinois method) ---------! - if (.not. zside) funz=funz * 0.5 - !----- We just updated aside, setting aside to true. --------------------------! - zside = .false. - end if - end do bisloop - - - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> ttripoli) then - dtempdrs = - temp * qhydm / (rcon * (hh+qhydm)) - else - dtempdrs = - temp * qhydm * htripolii / rcon - end if - else - til = cpi * thil * exner - !----- Deciding how to compute, based on temperature -----------------------------! - if (temp > ttripoli) then - dtempdrs = - til * qhydm /( rcon * cp * (2.*temp-til)) - else - dtempdrs = - til * qhydm * htripolii / rcon - end if - end if return - end function dtempdrs + end function alvl !=======================================================================================! !=======================================================================================! @@ -2061,35 +2661,27 @@ end function dtempdrs !=======================================================================================! !=======================================================================================! - ! This fucntion computes the change of ice-liquid potential temperature due to ! - ! sedimentation. The arguments are ice-liquid potential temperature, potential temper- ! - ! ature and temperature in Kelvin, the old and new mixing ratio [kg/kg] and the old and ! - ! new enthalpy [J/kg]. ! + ! This function finds the latent heat of sublimation for a given temperature. If ! + ! we use the definition of latent heat (difference in enthalpy between ice and vapour ! + ! phases), and assume that the specific heats are constants, latent heat becomes a ! + ! linear function of temperature. ! !---------------------------------------------------------------------------------------! - real function dthil_sedimentation(thil,theta,temp,rold,rnew,qrold,qrnew) - use rconstants, only: ttripoli,cp,alvi,alvl - + real(kind=4) function alvi(temp) + use rconstants , only : alvi3 & ! intent(in) + , dcpvi & ! intent(in) + , t3ple ! ! intent(in) implicit none - !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: thil ! Ice-liquid potential temperature [ K] - real, intent(in) :: theta ! Potential temperature [ K] - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: rold ! Old hydrometeor mixing ratio [ kg/kg] - real, intent(in) :: rnew ! New hydrometeor mixing ratio [ kg/kg] - real, intent(in) :: qrold ! Old hydrometeor latent enthalpy [ J/kg] - real, intent(in) :: qrnew ! New hydrometeor latent enthalpy [ J/kg] + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: temp !------------------------------------------------------------------------------------! - if (newthermo) then - dthil_sedimentation = - thil * (alvi*(rnew-rold) - (qrnew-qrold)) & - / (cp * max(temp,ttripoli)) - else - dthil_sedimentation = - thil*thil * (alvi*(rnew-rold) - (qrnew-qrold)) & - / (cp * max(temp,ttripoli) * theta) - end if + + !----- Linear function, using latent heat at the triple point as reference. ---------! + alvi = alvi3 + dcpvi * (temp - t3ple) + !------------------------------------------------------------------------------------! return - end function dthil_sedimentation + end function alvi !=======================================================================================! !=======================================================================================! @@ -2100,43 +2692,68 @@ end function dthil_sedimentation !=======================================================================================! !=======================================================================================! - ! This function computes the ice-vapour equivalent potential temperature from ! - ! theta_iland the total mixing ratio. This is equivalent to the equivalent potential ! - ! temperature considering also the effects of fusion/melting/sublimation. ! - ! In case you want to find thetae (i.e. without ice) simply provide the logical ! - ! useice as .false. . ! + ! This fucntion computes the ice liquid potential temperature given the Exner ! + ! function [J/kg/K], temperature [K], and liquid and ice mixing ratios [kg/kg]. ! !---------------------------------------------------------------------------------------! - real function thetaeiv(thil,pres,temp,rvap,rtot,iflg,useice) - use rconstants, only : alvl,alvi,cp,ep,p00,rocp,ttripoli,t3ple + real(kind=4) function theta_iceliq(exner,temp,rliq,rice) + use rconstants , only : alvl3 & ! intent(in) + , alvi3 & ! intent(in) + , cpdry & ! intent(in) + , ttripoli & ! intent(in) + , htripoli & ! intent(in) + , htripolii ! ! intent(in) + implicit none !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: thil ! Ice-liquid water potential temp. [ K] - real , intent(in) :: pres ! Pressure [ Pa] - real , intent(in) :: temp ! Temperature [ K] - real , intent(in) :: rvap ! Water vapour mixing ratio [ kg/kg] - real , intent(in) :: rtot ! Total mixing ratio [ kg/kg] - integer, intent(in) :: iflg ! Just to tell where this has been called. - logical, intent(in), optional :: useice ! Should I use ice? [ T|F] - !----- Local variables for iterative method -----------------------------------------! - real :: tlcl ! Internal LCL temperature [ K] - real :: plcl ! Lifting condensation pressure [ Pa] - real :: dzlcl ! Thickness of layer beneath LCL [ m] + real(kind=4), intent(in) :: exner ! Exner function [ J/kg/K] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] + real(kind=4), intent(in) :: rice ! Ice mixing ratio [ kg/kg] + !----- Local variables --------------------------------------------------------------! + real(kind=4) :: hh ! Enthalpy associated with sensible heat [ J/kg] + real(kind=4) :: qq ! Enthalpy associated with latent heat [ J/kg] !------------------------------------------------------------------------------------! - if (present(useice)) then - call lcl_il(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl,iflg,useice) + + !----- Find the sensible heat enthalpy (assuming dry air). --------------------------! + hh = cpdry * temp + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the latent heat enthalpy. If using the old thermodynamics, we use the ! + ! latent heat at T = T3ple, otherwise we use the temperature-dependent one. ! + !------------------------------------------------------------------------------------! + if (newthermo) then + qq = alvl(temp) * rliq + alvi(temp) * rice else - call lcl_il(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl,iflg) + qq = alvl3 * rliq + alvi3 * rice end if + !------------------------------------------------------------------------------------! + !------------------------------------------------------------------------------------! - ! The definition of the thetae_iv is the thetae_ivs at the LCL. The LCL, in turn ! - ! is the point in which rtot = rvap = rsat, so at the LCL rliq = rice = 0. ! + ! Solve the thermodynamics. For the new thermodynamics we don't approximate ! + ! the exponential to a linear function, nor do we impose temperature above the thre- ! + ! shold from Tripoli and Cotton (1981). ! + !------------------------------------------------------------------------------------! + if (newthermo) then + !----- Decide how to compute, based on temperature. ------------------------------! + theta_iceliq = hh * exp(-qq / hh) / exner + !---------------------------------------------------------------------------------! + else + !----- Decide how to compute, based on temperature. ------------------------------! + if (temp > ttripoli) then + theta_iceliq = hh * hh / (exner * ( hh + qq)) + else + theta_iceliq = hh * htripoli / (exner * ( htripoli + qq)) + end if + !---------------------------------------------------------------------------------! + end if !------------------------------------------------------------------------------------! - thetaeiv = thetaeivs(thil,tlcl,rtot,0.,0.) return - end function thetaeiv + end function theta_iceliq !=======================================================================================! !=======================================================================================! @@ -2147,49 +2764,132 @@ end function thetaeiv !=======================================================================================! !=======================================================================================! - ! This function computes the derivative of ice-vapour equivalent potential tempera- ! - ! ture, based on the expression used to compute the ice-vapour equivalent potential ! - ! temperature (function thetaeiv). ! - ! ! - ! IMPORTANT!!! This CANNOT BE USED to compute d(Thetae_ivs)/dT, because here ! - ! we assume that T(LCL) and saturation mixing ratio are known and ! - ! constants, and that the LCL pressure (actually the saturation vapour ! - ! pressure at the LCL) is a function of temperature. In case you want ! - ! d(Thetae_ivs)/dT, use the dthetaeivs_dt function instead. ! + ! This function computes the liquid potential temperature derivative with respect ! + ! to temperature, useful in iterative methods. ! !---------------------------------------------------------------------------------------! - real function dthetaeiv_dtlcl(theiv,tlcl,rtot,eslcl,useice) - use rconstants, only : rocp,aklv,ttripoli + real(kind=4) function dthetail_dt(condconst,thil,exner,pres,temp,rliq,ricein) + use rconstants , only : alvl3 & ! intent(in) + , alvi3 & ! intent(in) + , dcpvi & ! intent(in) + , dcpvl & ! intent(in) + , cpdry & ! intent(in) + , ttripoli & ! intent(in) + , htripoli & ! intent(in) + , htripolii & ! intent(in) + , t3ple ! ! intent(in) + implicit none !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: theiv ! Ice-vapour equiv. pot. temp. [ K] - real , intent(in) :: tlcl ! LCL temperature [ K] - real , intent(in) :: rtot ! Total mixing ratio (rs @ LCL) [ Pa] - real , intent(in) :: eslcl ! LCL saturation vapour pressure [ Pa] - logical, intent(in), optional :: useice ! Flag for considering ice [ T|F] + logical , intent(in) :: condconst ! Condensation is constant? [ T|F] + real(kind=4), intent(in) :: thil ! Ice liquid pot. temp. [ K] + real(kind=4), intent(in) :: exner ! Exner function [J/kg/K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rliq ! Liquid mixing ratio [ kg/kg] + real(kind=4), intent(in), optional :: ricein ! Ice mixing ratio [ kg/kg] !----- Local variables --------------------------------------------------------------! - real :: desdtlcl ! Saturated vapour pres. deriv. [ Pa/K] + real(kind=4) :: rice ! Ice mixing ratio or 0. [ kg/kg] + real(kind=4) :: ldrst ! L × d(rs)/dT × T [ J/kg] + real(kind=4) :: rdlt ! r × d(L)/dT × T [ J/kg] + real(kind=4) :: hh ! Sensible heat enthalpy [ J/kg] + real(kind=4) :: qq ! Latent heat enthalpy [ J/kg] + logical :: thereisice ! Is ice present [ ---] !------------------------------------------------------------------------------------! + !------------------------------------------------------------------------------------! + ! Check whether we should consider ice thermodynamics or not. ! + !------------------------------------------------------------------------------------! + thereisice = present(ricein) + if (thereisice) then + rice = ricein + else + rice = 0. + end if + !------------------------------------------------------------------------------------! + - !----- Finding the derivative of rs with temperature --------------------------------! - if (present(useice)) then - desdtlcl = eslifp(tlcl,useice) + !------------------------------------------------------------------------------------! + ! Check whether the current state has condensed water. ! + !------------------------------------------------------------------------------------! + if (rliq+rice == 0.) then + !----- No condensation, so dthetail_dt is a constant. ----------------------------! + dthetail_dt = thil/temp + return + !---------------------------------------------------------------------------------! else - desdtlcl = eslifp(tlcl) + !---------------------------------------------------------------------------------! + ! Condensation exists. Compute some auxiliary variables. ! + !---------------------------------------------------------------------------------! + + + !---- Sensible heat enthalpy. ----------------------------------------------------! + hh = cpdry * temp + !---------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------! + ! Find the latent heat enthalpy. If using the old thermodynamics, we use ! + ! the latent heat at T = T3ple, otherwise we use the temperature-dependent one. ! + ! The term r × d(L)/dT × T is computed only when we use the new thermodynamics. ! + !---------------------------------------------------------------------------------! + if (newthermo) then + qq = alvl(temp) * rliq + alvi(temp) * rice + rdlt = (dcpvl * rliq + dcpvi * rice ) * temp + else + qq = alvl3 * rliq + alvi3 * rice + rdlt = 0.0 + end if + !---------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------! + ! This is the term L×[d(rs)/dt]×T. L may be either the vapourisation or ! + ! sublimation latent heat, depending on the temperature and whether we are consi- ! + ! dering ice or not. We still need to check whether latent heat is a function of ! + ! temperature or not. Also, if condensation mixing ratio is constant, then this ! + ! term will be always zero. ! + !---------------------------------------------------------------------------------! + if (condconst) then + ldrst = 0. + elseif (thereisice .and. temp < t3ple) then + if (newthermo) then + ldrst = alvi3 * rsifp(pres,temp) * temp + else + ldrst = alvi(temp) * rsifp(pres,temp) * temp + end if + else + if (newthermo) then + ldrst = alvl3 * rslfp(pres,temp) * temp + else + ldrst = alvl(temp) * rslfp(pres,temp) * temp + end if + end if + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! - !----- Finding the derivative. Depending on the temperature, use different eqn. -----! - if (tlcl > ttripoli) then - dthetaeiv_dtlcl = theiv * (1. - rocp*tlcl*desdtlcl/eslcl - aklv*rtot/tlcl) / tlcl + !------------------------------------------------------------------------------------! + ! Find the condensed phase consistent with the thermodynamics used. ! + !------------------------------------------------------------------------------------! + if (newthermo) then + dthetail_dt = thil * ( 1. + (ldrst + qq - rdlt ) / hh ) / temp else - dthetaeiv_dtlcl = theiv * (1. - rocp*tlcl*desdtlcl/eslcl ) / tlcl + !----- Decide how to compute, based on temperature. ------------------------------! + if (temp > ttripoli) then + dthetail_dt = thil * ( 1. + (ldrst + qq) / (hh+qq) ) / temp + else + dthetail_dt = thil * ( 1. + ldrst / (htripoli + alvl3 * rliq) ) / temp + end if + !---------------------------------------------------------------------------------! end if + !------------------------------------------------------------------------------------! return - end function dthetaeiv_dtlcl + end function dthetail_dt !=======================================================================================! !=======================================================================================! @@ -2200,38 +2900,257 @@ end function dthetaeiv_dtlcl !=======================================================================================! !=======================================================================================! - ! This function computes the saturation ice-vapour equivalent potential temperature ! - ! from theta_il and the total mixing ratio (split into saturated vapour plus liquid and ! - ! ice. This is equivalent to the equivalent potential temperature considering also the ! - ! effects of fusion/melting/sublimation, and it is done separatedly from the regular ! - ! thetae_iv because it doesn't require iterations. ! - ! ! - ! References: ! - ! Tripoli, J. T.; and Cotton, W.R., 1981: The use of ice-liquid water potential tem- ! - ! perature as a thermodynamic variable in deep atmospheric models. Mon. Wea. ! - ! Rev., v. 109, 1094-1102. (TC81) ! - ! ! - ! Some algebra was needed to find this equation, essentially combining (TC81-26) and ! - ! (TC81-27), and the conservation of total water (TC81-16). It assumes that the divi- ! - ! sion between the three phases is already taken care of. ! + ! This function computes temperature from the ice-liquid water potential temperature ! + ! in Kelvin, Exner function in J/kg/K, and liquid and ice mixing ratios in kg/kg. ! + ! For now t1stguess is used only to decide whether I should use the complete case or ! + ! the 253 K to reduce the error on neglecting the changes on latent heat due to temper- ! + ! ature. ! !---------------------------------------------------------------------------------------! - real function thetaeivs(thil,temp,rsat,rliq,rice) - use rconstants, only : aklv, ttripoli + real(kind=4) function thil2temp(thil,exner,pres,rliq,rice,t1stguess) + use rconstants , only : cpdry & ! intent(in) + , cpdryi & ! intent(in) + , cpdryi4 & ! intent(in) + , alvl3 & ! intent(in) + , alvi3 & ! intent(in) + , t00 & ! intent(in) + , t3ple & ! intent(in) + , ttripoli & ! intent(in) + , htripolii ! ! intent(in) implicit none - real, intent(in) :: thil ! Theta_il, ice-liquid water potential temp. [ K] - real, intent(in) :: temp ! Temperature [ K] - real, intent(in) :: rsat ! Saturation water vapour mixing ratio [ kg/kg] - real, intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] - real, intent(in) :: rice ! Ice mixing ratio [ kg/kg] + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: thil ! Ice-liquid water potential temp. [ K] + real(kind=4), intent(in) :: exner ! Exner function [J/kg/K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] + real(kind=4), intent(in) :: rice ! Ice mixing ratio [ kg/kg] + real(kind=4), intent(in) :: t1stguess ! 1st. guess for temperature [ K] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: til ! Ice liquid temperature [ K] + real(kind=4) :: deriv ! Function derivative + real(kind=4) :: fun ! Function for which we seek a root. + real(kind=4) :: funa ! Smallest guess function + real(kind=4) :: funz ! Largest guess function + real(kind=4) :: tempa ! Smallest guess (or previous guess in Newton) + real(kind=4) :: tempz ! Largest guess (or new guess in Newton) + real(kind=4) :: delta ! Aux. var to compute 2nd guess for bisection + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + logical :: converged ! Convergence flag + logical :: zside ! Flag to check for one-sided approach... + !------------------------------------------------------------------------------------! - real :: rtots ! Saturated mixing ratio [ K] - rtots = rsat+rliq+rice - - thetaeivs = thil * exp ( aklv * rtots / max(temp,ttripoli)) + !------------------------------------------------------------------------------------! + ! First we check for conditions that don't require iterative root-finding. ! + !------------------------------------------------------------------------------------! + if (rliq + rice == 0.) then + !----- No condensation. Theta_il is the same as theta. --------------------------! + thil2temp = cpdryi * thil * exner + return + !---------------------------------------------------------------------------------! + elseif (.not. newthermo) then + !---------------------------------------------------------------------------------! + ! There is condensation but we are using the old thermodynamics, which can be ! + ! solved analytically. ! + !---------------------------------------------------------------------------------! + til = cpdryi * thil * exner + if (t1stguess > ttripoli) then + thil2temp = 0.5 & + * (til + sqrt(til * (til + cpdryi4 * (alvl3 * rliq + alvi3 * rice)))) + else + thil2temp = til * ( 1. + (alvl3 * rliq + alvi3 * rice) * htripolii) + end if + return + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,a,1x,f11.4,2(1x,a,1x,es12.5))') & + ! 'itn=',itn,'bisection=',.false.,'tempz=',tempz-t00 & + ! ,'fun=',fun,'deriv=',deriv + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + converged = abs(tempa-tempz) < toler*tempz + !----- Converged, happy with that, return the average b/w the 2 previous guesses -! + if (fun == 0.) then + thil2temp = tempz + converged = .true. + return + elseif(converged) then + thil2temp = 0.5 * (tempa+tempz) + return + end if + end do newloop + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! If we have reached this point then Newton's method failed. Use bisection ! + ! instead. For bisection, We need two guesses whose function evaluations have ! + ! opposite sign. ! + !------------------------------------------------------------------------------------! + if (funa * fun < 0.) then + !----- Guesses have opposite sign. -----------------------------------------------! + funz = fun + zside = .true. + else + if (abs(fun-funa) < toler*tempa) then + delta = 100.*toler*tempa + else + delta = max(abs(funa * (tempz-tempa)/(fun-funa)),100.*toler*tempa) + end if + tempz = tempa + delta + zside = .false. + zgssloop: do itb=1,maxfpo + tempz = tempa + real((-1)**itb * (itb+3)/2) * delta + funz = theta_iceliq(exner,tempz,rliq,rice) - thil + zside = funa*funz < 0.0 + if (zside) exit zgssloop + end do zgssloop + if (.not. zside) then + write (unit=*,fmt='(a)') ' No second guess for you...' + write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'thil =',thil ,'t1st=',t1stguess + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'exner=',exner,'pres=',pres + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'rliq =',rliq ,'rice=',rice + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempa=',tempa,'funa=',funa + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tempz=',tempz,'funz=',funz + write (unit=*,fmt='(1(a,1x,es14.7,1x))') 'delta=',delta + call abort_run ('Failed finding the second guess for regula falsi' & + ,'thil2temp','therm_lib.f90') + end if + end if + + + bisloop: do itb=itn,maxfpo + thil2temp = (funz*tempa-funa*tempz)/(funz-funa) + + !---------------------------------------------------------------------------------! + ! Now that we updated the guess, check whether they are really close. If so, ! + ! it converged, I can use this as my guess. ! + !---------------------------------------------------------------------------------! + converged = abs(thil2temp-tempa)< toler*thil2temp + if (converged) exit bisloop + + !------ Finding the new function -------------------------------------------------! + fun = theta_iceliq(exner,tempz,rliq,rice) - thil + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write(unit=89,fmt='(a,1x,i5,1x,a,1x,l1,1x,6(1x,a,1x,f11.4))') & + ! 'itn=',itb,'bisection=',.true. & + ! ,'temp=',thil2temp-t00,'tempa=',tempa-t00,'tempz=',tempz-t00 & + ! ,'fun=',fun,'funa=',funa,'funz=',funz + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + !------ Defining my new interval based on the intermediate value theorem. --------! + if (fun*funa < 0. ) then + tempz = thil2temp + funz = fun + !----- If we are updating zside again, modify aside (Illinois method) ---------! + if (zside) funa=funa * 0.5 + !----- We just updated zside, setting zside to true. --------------------------! + zside = .true. + else + tempa = thil2temp + funa = fun + !----- If we are updating aside again, modify aside (Illinois method) ---------! + if (.not. zside) funz=funz * 0.5 + !----- We just updated aside, setting aside to true. --------------------------! + zside = .false. + end if + end do bisloop + + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> ttripoli) then + dtempdrs = - til * qq / ( rcon * cpdry * (2.*temp-til)) + else + dtempdrs = - til * qq * htripolii / rcon + end if + !------------------------------------------------------------------------------! + end if + !---------------------------------------------------------------------------------! + end if + !------------------------------------------------------------------------------------! + + return + end function dtempdrs + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the ice-vapour equivalent potential temperature from ! + ! theta_iland the total mixing ratio. This is equivalent to the equivalent potential ! + ! temperature considering also the effects of fusion/melting/sublimation. ! + ! In case you want to find thetae (i.e. without ice) simply set the the logical ! + ! useice to .false. . ! + !---------------------------------------------------------------------------------------! + real(kind=4) function thetaeiv(thil,pres,temp,rvap,rtot,useice) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: thil ! Ice-liquid potential temp. [ K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rvap ! Water vapour mixing ratio [ kg/kg] + real(kind=4), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! Should I use ice? [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: tlcl ! Internal LCL temperature [ K] + real(kind=4) :: plcl ! Lifting condensation pressure [ Pa] + real(kind=4) :: dzlcl ! Thickness of lyr. beneath LCL [ m] + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Find the liquid condensation level (LCL). ! + !------------------------------------------------------------------------------------! + if (present(useice)) then + call lcl_il(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl,useice) + else + call lcl_il(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl) + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! The definition of the thetae_iv is the thetae_ivs at the LCL. The LCL, in turn ! + ! is the point in which rtot = rvap = rsat, so at the LCL rliq = rice = 0. ! + !------------------------------------------------------------------------------------! + thetaeiv = thetaeivs(thil,tlcl,rtot,0.,0.) + !------------------------------------------------------------------------------------! + + return + end function thetaeiv + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the derivative of ice-vapour equivalent potential tempera- ! + ! ture, based on the expression used to compute the ice-vapour equivalent potential ! + ! temperature (function thetaeiv). ! + ! ! + ! IMPORTANT!!! This CANNOT BE USED to compute d(Thetae_ivs)/dT, because here ! + ! we assume that T(LCL) and saturation mixing ratio are known and ! + ! constants, and that the LCL pressure (actually the saturation vapour ! + ! pressure at the LCL) is a function of temperature. In case you want ! + ! d(Thetae_ivs)/dT, use the dthetaeivs_dt function instead. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function dthetaeiv_dtlcl(theiv,tlcl,rtot,eslcl,useice) + use rconstants , only : rocp & ! intent(in) + , cpdry & ! intent(in) + , dcpvl ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: theiv ! Ice-vap. equiv. pot. temp. [ K] + real(kind=4), intent(in) :: tlcl ! LCL temperature [ K] + real(kind=4), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + real(kind=4), intent(in) :: eslcl ! LCL sat. vapour pressure [ Pa] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! Flag for considering ice [ T|F] + !----- Local variables --------------------------------------------------------------! + real(kind=4) :: desdtlcl ! Sat. vapour pres. deriv. [ Pa/K] + real(kind=4) :: esterm ! es(TLC) term [ ----] + real(kind=4) :: hhlcl ! Enthalpy -- sensible [ J/kg] + real(kind=4) :: qqlcl ! Enthalpy -- latent [ J/kg] + real(kind=4) :: qptlcl ! Latent deriv. * T_LCL [ J/kg] + !------------------------------------------------------------------------------------! + + + + !----- Find the derivative of rs with temperature. ----------------------------------! + if (present(useice)) then + desdtlcl = eslifp(tlcl,useice) + else + desdtlcl = eslifp(tlcl) + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Saturation term. ! + !------------------------------------------------------------------------------------! + esterm = rocp * tlcl * desdtlcl / eslcl + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Find the enthalpy terms. ! + !------------------------------------------------------------------------------------! + hhlcl = cpdry * tlcl + qqlcl = alvl(tlcl) * rtot + qptlcl = dcpvl * rtot * tlcl + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Derivative. ! + !------------------------------------------------------------------------------------! + dthetaeiv_dtlcl = theiv / tlcl * (1. - esterm - (qqlcl - qptlcl) / hhlcl) + !------------------------------------------------------------------------------------! + + return + end function dthetaeiv_dtlcl + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the saturation ice-vapour equivalent potential temperature ! + ! from theta_il and the total mixing ratio (split into saturated vapour plus liquid and ! + ! ice. This is equivalent to the equivalent potential temperature considering also the ! + ! effects of fusion/melting/sublimation, and it is done separatedly from the regular ! + ! thetae_iv because it doesn't require iterations. ! + ! ! + ! References: ! + ! Tripoli, J. T.; and Cotton, W.R., 1981: The use of ice-liquid water potential tem- ! + ! perature as a thermodynamic variable in deep atmospheric models. Mon. Wea. ! + ! Rev., v. 109, 1094-1102. (TC81) ! + ! ! + ! Some algebra was needed to find this equation, essentially combining (TC81-26) and ! + ! (TC81-27), and the conservation of total water (TC81-16). It assumes that the divi- ! + ! sion between the three phases is already taken care of. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function thetaeivs(thil,temp,rsat,rliq,rice) + use rconstants , only : cpdry ! ! intent(in) + implicit none + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: thil ! Theta_il, ice-liquid water pot. temp. [ K] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rsat ! Saturation water vapour mixing ratio [ kg/kg] + real(kind=4), intent(in) :: rliq ! Liquid water mixing ratio [ kg/kg] + real(kind=4), intent(in) :: rice ! Ice mixing ratio [ kg/kg] + !----- Local variables --------------------------------------------------------------! + real(kind=4) :: rtots ! Saturated mixing ratio [ K] + !------------------------------------------------------------------------------------! + + + !------ Find the total saturation mixing ratio. -------------------------------------! + rtots = rsat+rliq+rice + !------------------------------------------------------------------------------------! + + + !------ Find the saturation equivalent potential temperature. -----------------------! + thetaeivs = thil * exp ( alvl(temp) * rtots / (cpdry * temp)) + !------------------------------------------------------------------------------------! + + return + end function thetaeivs + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function computes the derivative of saturation ice-vapour equivalent ! + ! potential temperature, based on the expression used to compute the saturation ! + ! ice-vapour equivalent potential temperature (function thetaeivs). ! + ! ! + ! IMPORTANT!!! This CANNOT BE USED to compute d(Thetae_iv)/d(T_LCL), because here ! + ! we assume that temperature and pressure are known and constants, and ! + ! that the mixing ratio is a function of temperature. In case you want ! + ! d(Thetae_iv)/d(T_LCL), use the dthetaeiv_dtlcl function instead. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function dthetaeivs_dt(theivs,temp,pres,rsat,useice) + use rconstants , only : cpdry & ! intent(in) + , dcpvl ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: theivs ! Sat. ice-vap. eq. pot. temp. [ K] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rsat ! Saturation mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! Flag for considering ice [ T|F] + !----- Local variables --------------------------------------------------------------! + real(kind=4) :: drsdt ! Sat. mixing ratio derivative [kg/kg/K] + real(kind=4) :: hh ! Enthalpy -- sensible [ J/kg] + real(kind=4) :: qqaux ! Enthalpy -- sensible [ J/kg] + !------------------------------------------------------------------------------------! + + + !----- Find the derivative of rs with temperature and associated term. --------------! + if (present(useice)) then + drsdt = rslifp(pres,temp,useice) + else + drsdt = rslifp(pres,temp) + end if + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! Find the enthalpy terms. ! + !------------------------------------------------------------------------------------! + hh = cpdry * temp + qqaux = alvl(temp) * (drsdt * temp - rsat) + dcpvl * rsat * temp + !------------------------------------------------------------------------------------! + + + !----- Find the derivative. Depending on the temperature, use different eqn. -------! + dthetaeivs_dt = theivs / temp * ( 1. + qqaux / hh ) + !------------------------------------------------------------------------------------! + + return + end function dthetaeivs_dt + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This function finds the ice-liquid potential temperature from the ice-vapour equi- ! + ! valent potential temperature. ! + ! Important remarks: ! + ! 1. If you don't want to use ice thermodynamics, simply force useice to be .false. ! + ! Otherwise, the model will decide based on the LEVEL given by the user from their ! + ! RAMSIN. ! + ! 2. If rtot < rsat, then this will convert theta_e into theta, which can be thought as ! + ! a particular case. ! + !---------------------------------------------------------------------------------------! + real(kind=4) function thetaeiv2thil(theiv,pres,rtot,useice) + use rconstants , only : ep & ! intent(in) + , cpdry & ! intent(in) + , p00 & ! intent(in) + , rocp & ! intent(in) + , t3ple & ! intent(in) + , t00 ! ! intent(in) + implicit none + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: theiv ! Ice vap. equiv. pot. temp. [ K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in), optional :: useice ! May I use ice thermodyn. [ T|F] + !----- Local variables for iterative method -----------------------------------------! + real(kind=4) :: pvap ! Sat. vapour pressure + real(kind=4) :: theta ! Potential temperature + real(kind=4) :: deriv ! Function derivative + real(kind=4) :: funnow ! Function for which we seek a root. + real(kind=4) :: funa ! Smallest guess function + real(kind=4) :: funz ! Largest guess function + real(kind=4) :: tlcla ! Smallest guess (Newton: old guess) + real(kind=4) :: tlclz ! Largest guess (Newton: new guess) + real(kind=4) :: tlcl ! What will be the LCL temperature + real(kind=4) :: es00 ! Defined as p00*rt/(epsilon + rt) + real(kind=4) :: delta ! Aux. variable (For 2nd guess). + integer :: itn ! Iteration counters + integer :: itb ! Iteration counters + integer :: ii ! Another counter + logical :: converged ! Convergence handle + logical :: zside ! Side checker for Regula Falsi + logical :: frozen ! Will use ice thermodynamics + !------------------------------------------------------------------------------------! + + + + !----- Fill the flag for ice thermodynamics so it will be present. ------------------! + if (present(useice)) then + frozen = useice + else + frozen = bulk_on + end if + !------------------------------------------------------------------------------------! + + + + !----- Find es00, which is a constant. ----------------------------------------------! + es00 = p00 * rtot / (ep+rtot) + !------------------------------------------------------------------------------------! + + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + ! 'NEWTON: it=',itn,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funnow & + ! ,'deriv=',deriv + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + converged = abs(tlcla-tlclz) < toler * tlclz + if (funnow == 0.) then + tlcl = tlclz + funz = funnow + converged = .true. + exit newloop + elseif (converged) then + tlcl = 0.5*(tlcla+tlclz) + funz = funnow + exit newloop + end if + end do newloop + + !------------------------------------------------------------------------------------! + ! If I reached this point then it's because Newton's method failed. Using bisec- ! + ! tion instead. ! + !------------------------------------------------------------------------------------! + if (.not. converged) then + !----- Set funz, and check whether funa and funz already have opposite sign. -----! + funz = funnow + zside=.true. + if (funa*funnow > 0.) then + !----- We fix funa, and try a funz that will work as 2nd guess ----------------! + if (abs(funz-funa) < toler*tlcla) then + delta = 100.*toler*tlcla + else + delta = max(abs(funa*(tlclz-tlcla)/(funz-funa)),100.*toler*tlcla) + end if + tlclz = tlcla + delta + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + ! '2NGGSS: tt=',itb,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funz & + ! ,'delta=',delta + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + + zside = funa*funz < 0. + if (zside) exit zgssloop + end do zgssloop + if (.not. zside) then + write (unit=*,fmt='(a)') ' No second guess for you...' + write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theiv =',theiv ,'rtot =',rtot + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'pres =',pres ,'pvap =',pvap + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theta =',theta ,'delta =',delta + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlcla =',tlcla ,'funa =',funa + write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlclz =',tlclz ,'funz =',funz + call abort_run ('Failed finding the second guess for regula falsi' & + ,'thetaeiv2thil','therm_lib.f90') + end if + end if + !---- Continue iterative method. -------------------------------------------------! + fpoloop: do itb=itn+1,maxfpo + + !----- Update the guess. ------------------------------------------------------! + tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) + + !----- Updating function evaluation -------------------------------------------! + pvap = eslif(tlcl,frozen) + theta = tlcl * (es00/pvap)**rocp + funnow = thetaeivs(theta,tlcl,rtot,0.,0.) - theiv + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=36,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + ! 'ANSWER: itb=',itn,'tlcl=',tlcl-t00,'eslcl=',0.01*pvap & + ! ,'thil=',thetaeiv2thil,'funa=',funa,'funz=',funz + !write (unit=36,fmt='(a)') '-------------------------------------------------------' + !write (unit=36,fmt='(a)') ' ' + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + else + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + write (unit=*,fmt='(a)') ' THEIV2THIL failed!' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Input: ' + write (unit=*,fmt='(a,1x,f12.5)') ' THEIV [ K]:',theiv + write (unit=*,fmt='(a,1x,f12.5)') ' PRES [ Pa]:',pres * 100. + write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1000.*rtot + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Output: ' + write (unit=*,fmt='(a,1x,i12)') ' ITERATIONS :',itb + write (unit=*,fmt='(a,1x,f12.5)') ' PVAP [ hPa]:',pvap + write (unit=*,fmt='(a,1x,f12.5)') ' THETA [ K]:',theta + write (unit=*,fmt='(a,1x,f12.5)') ' TLCL [ °C]:',tlcl-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' TLCLA [ °C]:',tlcla-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' TLCLZ [ °C]:',tlclz-t00 + write (unit=*,fmt='(a,1x,es12.5)') ' FUNA [ K]:',funa + write (unit=*,fmt='(a,1x,es12.5)') ' FUNZ [ K]:',funz + write (unit=*,fmt='(a,1x,es12.5)') ' DERIV [ ---]:',deriv + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_A [ ---]:',abs(tlcl-tlcla)/tlcl + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_Z [ ---]:',abs(tlcl-tlclz)/tlcl + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + + call abort_run ('TLCL didn''t converge, qgave up!' & + ,'thetaeiv2thil','therm_lib.f90') + end if + + return + end function thetaeiv2thil + !=======================================================================================! + !=======================================================================================! + + + + + + + !=======================================================================================! + !=======================================================================================! + ! This subroutine converts saturated ice-vapour equivalent potential temperature ! + ! into temperature, given pressure in Pa, and theta_es in Kelvin. It also returns the ! + ! potential temperature in Kelvin, and saturation vapour mixing ratio in kg/kg. As ! + ! usual, we seek T using Newton's method as a starting point, and if it fails, we fall ! + ! back to the modified regula falsi (Illinois method). ! + ! ! + ! OBS: In case you want to ignore ice, send useice as false. The default is to consider ! + ! when level >= 3 and to ignore otherwise. ! + !---------------------------------------------------------------------------------------! + subroutine thetaeivs2temp(theivs,pres,theta,temp,rsat,useice) + use rconstants , only : cpdry & ! intent(in) + , ep & ! intent(in) + , p00 & ! intent(in) + , rocp & ! intent(in) + , t00 ! ! intent(in) + implicit none + !----- Arguments --------------------------------------------------------------------! + real(kind=4), intent(in) :: theivs ! Sat. thetae_iv [ K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(out) :: theta ! Potential temperature [ K] + real(kind=4), intent(out) :: temp ! Temperature [ K] + real(kind=4), intent(out) :: rsat ! Saturation mixing ratio [ kg/kg] + logical , intent(in) , optional :: useice ! May use ice thermodyn. [ T|F] + !----- Local variables, with other thermodynamic properties -------------------------! + real(kind=4) :: exnernormi ! 1./ (Norm. Exner func.) [ ---] + logical :: frozen ! Will use ice thermodyn. [ T|F] + !----- Local variables for iterative method -----------------------------------------! + real(kind=4) :: deriv ! Function derivative + real(kind=4) :: funnow ! Current function evaluation + real(kind=4) :: funa ! Smallest guess function + real(kind=4) :: funz ! Largest guess function + real(kind=4) :: tempa ! Smallest guess (Newton: previous) + real(kind=4) :: tempz ! Largest guess (Newton: new) + real(kind=4) :: delta ! Aux. variable for 2nd guess. + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + logical :: converged ! Convergence handle + logical :: zside ! Flag for side check. + !------------------------------------------------------------------------------------! + + + !----- Set up the ice check, in case useice is not present. -------------------------! + if (present(useice)) then + frozen = useice + else + frozen = bulk_on + end if + !------------------------------------------------------------------------------------! + + + + !----- Finding the inverse of normalised Exner, which is constant in this routine ---! + exnernormi = (p00 /pres) ** rocp + !------------------------------------------------------------------------------------! + + + + !------------------------------------------------------------------------------------! + ! The 1st. guess, no idea, guess 0°C. ! + !------------------------------------------------------------------------------------! + tempz = t00 + theta = tempz * exnernormi + rsat = rslif(pres,tempz,frozen) + funnow = thetaeivs(theta,tempz,rsat,0.,0.) + deriv = dthetaeivs_dt(funnow,tempz,pres,rsat,frozen) + funnow = funnow - theivs + !------------------------------------------------------------------------------------! + + + !----- Copy here just in case Newton is aborted at the 1st guess. -------------------! + tempa = tempz + funa = funnow + !------------------------------------------------------------------------------------! + + converged = .false. + !----- Newton's method loop. --------------------------------------------------------! + newloop: do itn=1,maxfpo/6 + if (abs(deriv) < toler) exit newloop !----- Too dangerous, skip to bisection -----! + !----- Updating guesses ----------------------------------------------------------! + tempa = tempz + funa = funnow + + tempz = tempa - funnow/deriv + theta = tempz * exnernormi + rsat = rslif(pres,tempz,frozen) + funnow = thetaeivs(theta,tempz,rsat,0.,0.) + deriv = dthetaeivs_dt(funnow,tempz,pres,rsat,frozen) + funnow = funnow - theivs + + converged = abs(tempa-tempz) < toler*tempz + if (funnow == 0.) then + converged =.true. + temp = tempz + exit newloop + elseif (converged) then + temp = 0.5*(tempa+tempz) + exit newloop + end if + end do newloop + !------------------------------------------------------------------------------------! + ! If we have reached this point then it's because Newton's method failed. Use ! + ! bisection instead. ! + !------------------------------------------------------------------------------------! + if (.not. converged) then + !----- Set funz, and check whether funa and funz already have opposite sign. -----! + funz = funnow + zside = .false. + !---------------------------------------------------------------------------------! + if (funa*funnow > 0.) then + !----- We fix funa, and try a funz that will work as 2nd guess ----------------! + if (abs(funz-funa) < toler*tempa) then + delta = 100.*toler*tempa + else + delta = max(abs(funa*(tempz-tempa)/(funz-funa)),100.*toler*tempa) + end if + !------------------------------------------------------------------------------! - !----- Finding the derivative of rs with temperature --------------------------------! - if (present(useice)) then - drsdt = rslifp(pres,temp,useice) - else - drsdt = rslifp(pres,temp) - end if + tempz = tempa + delta + zgssloop: do itb=1,maxfpo + !----- So this will be +1 -1 +2 -2 etc. ------------------------------------! + tempz = tempz + real((-1)**itb * (itb+3)/2) * delta + theta = tempz * exnernormi + rsat = rslif(pres,tempz,frozen) + funz = thetaeivs(theta,tempz,rsat,0.,0.) - theivs + zside = funa*funz < 0. + if (zside) exit zgssloop + end do zgssloop + if (.not. zside) then + call abort_run ('Failed finding the second guess for regula falsi' & + ,'thetaes2temp','therm_lib.f90') + end if + end if + !---- Continue iterative method --------------------------------------------------! + fpoloop: do itb=itn+1,maxfpo + if (abs(funz-funa) < toler*tempa) then + temp = 0.5*(tempa+tempz) + else + temp = (funz*tempa-funa*tempz)/(funz-funa) + end if + theta = temp * exnernormi + rsat = rslif(pres,temp,frozen) + funnow = thetaeivs(theta,temp,rsat,0.,0.) - theivs + !------------------------------------------------------------------------------! + ! Checking for convergence. If it did, return, we found the solution. ! + ! Otherwise, constrain the guesses. ! + !------------------------------------------------------------------------------! + converged = abs(temp-tempa) < toler*temp + if (converged) then + exit fpoloop + elseif (funnow*funa < 0.) then + tempz = temp + funz = funnow + !----- If we are updating zside again, modify aside (Illinois method) ------! + if (zside) funa=funa * 0.5 + !----- We just updated zside, setting zside to true. -----------------------! + zside = .true. + else + tempa = temp + funa = funnow + !----- If we are updating aside again, modify zside (Illinois method) ------! + if (.not. zside) funz = funz * 0.5 + !----- We just updated aside, setting zside to false -----------------------! + zside = .false. + end if + end do fpoloop + end if - !----- Finding the derivative. Depending on the temperature, use different eqn. -----! - if (temp > ttripoli) then - dthetaeivs_dt = theivs * (1. + aklv * (drsdt*temp-rsat)/temp ) / temp + if (converged) then + !----- Compute theta and rsat with temp just for consistency ---------------------! + theta = temp * exnernormi + rsat = rslif(pres,temp,frozen) else - dthetaeivs_dt = theivs * (1. + alvl * drsdt * temp * htripolii ) / temp + call abort_run ('Temperature didn''t converge, I gave up!' & + ,'thetaes2temp','therm_lib.f90') end if - return - end function dthetaeivs_dt + end subroutine thetaeivs2temp !=======================================================================================! !=======================================================================================! @@ -2293,258 +3973,348 @@ end function dthetaeivs_dt !=======================================================================================! !=======================================================================================! - ! This function finds the ice-liquid potential temperature from the ice-vapour equi- ! - ! valent potential temperature. ! + ! This subroutine finds the lifting condensation level given the ice-liquid ! + ! potential temperature in Kelvin, temperature in Kelvin, the pressure in Pascal, and ! + ! the mixing ratio in kg/kg. The output will give the LCL temperature and pressure, and ! + ! the thickness of the layer between the initial point and the LCL. ! + ! ! + ! References: ! + ! Tripoli, J. T.; and Cotton, W.R., 1981: The use of ice-liquid water potential ! + ! temperature as a thermodynamic variable in deep atmospheric models. Mon. Wea. ! + ! Rev., v. 109, 1094-1102. (TC81) ! + ! Bolton, D., 1980: The computation of the equivalent potential temperature. Mon. ! + ! Wea. Rev., v. 108, 1046-1053. (BO80) ! + ! ! + ! Some algebra was needed to find this equation, essentially combining (TC81-26) and ! + ! (TC81-27), and the conservation of total water (TC81-16). It assumes that the divi- ! + ! sion between the three phases is already taken care of. ! + ! Iterative procedure is needed, and here we iterate looking for T(LCL). Theta_il ! + ! can be rewritten in terms of T(LCL) only, and once we know this thetae_iv becomes ! + ! straightforward. T(LCL) will be found using Newton's method, and in the unlikely ! + ! event it fails,we will fall back to the modified regula falsi (Illinois method). ! + ! ! ! Important remarks: ! - ! 1. If you don't want to use ice thermodynamics, simply force useice to be .false. ! - ! Otherwise, the model will decide based on the LEVEL given by the user from their ! - ! RAMSIN. ! - ! 2. If rtot < rsat, then this will convert theta_e into theta, which can be thought as ! - ! a particular case. ! + ! 1. TLCL and PLCL are the actual TLCL and PLCL, so in case condensation exists, they ! + ! will be larger than the actual temperature and pressure (because one would go down ! + ! to reach the equilibrium); ! + ! 2. DZLCL WILL BE SET TO ZERO in case the LCL is beneath the starting level. So in ! + ! case you want to force TLCL <= TEMP and PLCL <= PRES, you can use this variable ! + ! to run the saturation check afterwards. DON'T CHANGE PLCL and TLCL here, they will ! + ! be used for conversions between theta_il and thetae_iv as they are defined here. ! + ! 3. In case you don't want ice, simply pass useice=.false.. Otherwise let the model ! + ! decide by itself based on the LEVEL variable. ! !---------------------------------------------------------------------------------------! - real function thetaeiv2thil(theiv,pres,rtot,useice) - use rconstants, only : alvl,cp,ep,p00,rocp,ttripoli,t3ple,t00 + subroutine lcl_il(thil,pres,temp,rtot,rvap,tlcl,plcl,dzlcl,useice) + use rconstants , only : cpog & ! intent(in) + , ep & ! intent(in) + , p00 & ! intent(in) + , rocp & ! intent(in) + , t3ple & ! intent(in) + , t00 ! ! intent(in) implicit none - !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: theiv ! Ice vapour equiv. pot. temp. [ K] - real , intent(in) :: pres ! Pressure [ Pa] - real , intent(in) :: rtot ! Total mixing ratio [ kg/kg] - logical, intent(in), optional :: useice ! Flag for considering ice thermo [ T|F] - !----- Local variables for iterative method -----------------------------------------! - real :: pvap ! Sat. vapour pressure - real :: theta ! Potential temperature - real :: deriv ! Function derivative - real :: funnow ! Function for which we seek a root. - real :: funa ! Smallest guess function - real :: funz ! Largest guess function - real :: tlcla ! Smallest guess (or old guess in Newton) - real :: tlclz ! Largest guess (or new guess in Newton) - real :: tlcl ! What will be the LCL temperature - real :: es00 ! Defined as p00*rt/(epsilon + rt) - real :: delta ! Aux. variable (For 2nd guess). - integer :: itn,itb ! Iteration counters - integer :: ii ! Another counter - logical :: converged ! Convergence handle - logical :: zside ! Aux. flag - check sides for Regula Falsi - logical :: brrr_cold ! Flag - considering ice thermo. - !------------------------------------------------------------------------------------! - - !----- Filling the flag for ice thermo that will be always present ------------------! + !----- Required arguments. ----------------------------------------------------------! + real(kind=4), intent(in) :: thil ! Ice liquid pot. temp. (*)[ K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: temp ! Temperature [ K] + real(kind=4), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + real(kind=4), intent(in) :: rvap ! Vapour mixing ratio [ kg/kg] + real(kind=4), intent(out) :: tlcl ! LCL temperature [ K] + real(kind=4), intent(out) :: plcl ! LCL pressure [ Pa] + real(kind=4), intent(out) :: dzlcl ! Sub-LCL layer thickness [ m] + !------------------------------------------------------------------------------------! + ! (*) This is the most general variable. Thil is exactly theta for no condensation ! + ! condition, and it is the liquid potential temperature if no ice is present. ! + !------------------------------------------------------------------------------------! + !----- Optional arguments. ----------------------------------------------------------! + logical , intent(in) , optional :: useice ! May use ice thermodyn.? [ T|F] + !----- Local variables. -------------------------------------------------------------! + real(kind=4) :: pvap ! Sat. vapour pressure + real(kind=4) :: deriv ! Function derivative + real(kind=4) :: funnow ! Current function evaluation + real(kind=4) :: funa ! Smallest guess function + real(kind=4) :: funz ! Largest guess function + real(kind=4) :: tlcla ! Smallest guess (Newton: previous) + real(kind=4) :: tlclz ! Largest guess (Newton: new) + real(kind=4) :: es00 ! Defined as p00*rt/(epsilon + rt) + real(kind=4) :: delta ! Aux. variable for bisection + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + logical :: converged ! Convergence flag + logical :: zside ! Flag to check sides + logical :: frozen ! Will use ice thermodyn. [ T|F] + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Check whether ice thermodynamics is the way to go. ! + !------------------------------------------------------------------------------------! if (present(useice)) then - brrr_cold = useice - else - brrr_cold = bulk_on + frozen = useice + else + frozen = bulk_on end if - - !----- Finding es00, which is a constant --------------------------------------------! - es00 = p00 * rtot / (ep+rtot) - + !------------------------------------------------------------------------------------! !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & ! 'NEWTON: it=',itn,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funnow & ! ,'deriv=',deriv !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - converged = abs(tlcla-tlclz) < toler * tlclz - if (funnow == 0.) then - tlcl = tlclz + !---------------------------------------------------------------------------------! + ! Check for convergence. ! + !---------------------------------------------------------------------------------! + converged = abs(tlcla-tlclz) < toler*tlclz + if (converged) then + !----- Guesses are almost identical, average them. ----------------------------! + tlcl = 0.5*(tlcla+tlclz) funz = funnow - converged = .true. exit newloop - elseif (converged) then - tlcl = 0.5*(tlcla+tlclz) + !------------------------------------------------------------------------------! + elseif (funnow == 0.) then + !----- We've hit the answer by luck, copy the answer. -------------------------! + tlcl = tlclz funz = funnow + converged = .true. exit newloop + !------------------------------------------------------------------------------! end if end do newloop + !------------------------------------------------------------------------------------! + + !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! + ! Check whether Newton's method has converged. ! !------------------------------------------------------------------------------------! if (.not. converged) then - !----- Set funz, and check whether funa and funz already have opposite sign. -----! - funz = funnow - zside=.true. - if (funa*funnow > 0.) then + !---------------------------------------------------------------------------------! + ! Newton's method has failed. We use regula falsi instead. First, we must ! + ! find two guesses whose function evaluations have opposite signs. ! + !---------------------------------------------------------------------------------! + if (funa*funnow < 0. ) then + !----- We already have two good guesses. --------------------------------------! + funz = funnow + zside = .true. + !------------------------------------------------------------------------------! + else + !------------------------------------------------------------------------------! + ! We need to find another guess with opposite sign. ! + !------------------------------------------------------------------------------! + !----- We fix funa, and try a funz that will work as 2nd guess ----------------! - if (abs(funz-funa) < toler*tlcla) then + if (abs(funnow-funa) < toler*tlcla) then delta = 100.*toler*tlcla else - delta = max(abs(funa*(tlclz-tlcla)/(funz-funa)),100.*toler*tlcla) + delta = max(abs(funa*(tlclz-tlcla)/(funnow-funa)),100.*toler*tlcla) end if tlclz = tlcla + delta + !------------------------------------------------------------------------------! !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=36,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & ! '2NGGSS: tt=',itb,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funz & ! ,'delta=',delta !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - - zside = funa*funz < 0 + zside = funa*funz < 0.0 if (zside) exit zgssloop end do zgssloop if (.not. zside) then - write (unit=*,fmt='(a)') ' No second guess for you...' - write (unit=*,fmt='(2(a,1x,i14,1x))') 'itn =',itn ,'itb =',itb - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theiv =',theiv ,'rtot =',rtot - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'pres =',pres ,'pvap =',pvap - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'theta =',theta ,'delta =',delta - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlcla =',tlcla ,'funa =',funa - write (unit=*,fmt='(2(a,1x,es14.7,1x))') 'tlclz =',tlclz ,'funz =',funz - call abort_run('Failed finding the second guess for regula falsi' & - ,'thetaeiv2thil','therm_lib.f90') + write (unit=*,fmt='(a)') ' ====== No second guess for you... ======' + write (unit=*,fmt='(a)') ' + INPUT variables: ' + write (unit=*,fmt='(a,1x,es14.7)') 'THIL =',thil + write (unit=*,fmt='(a,1x,es14.7)') 'TEMP =',temp + write (unit=*,fmt='(a,1x,es14.7)') 'PRES =',pres + write (unit=*,fmt='(a,1x,es14.7)') 'RTOT =',rtot + write (unit=*,fmt='(a,1x,es14.7)') 'RVAP =',rvap + write (unit=*,fmt='(a)') ' ============ Failed guess... ===========' + write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLA =',tlcla,'FUNA =',funa + write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLZ =',tlclz,'FUNC =',funz + write (unit=*,fmt='(2(a,1x,es14.7))') 'DELTA =',delta,'FUNN =',funnow + call abort_run ('Failed finding the second guess for regula falsi' & + ,'lcl_il','therm_lib.f90') end if end if - !---- Continue iterative method --------------------------------------------------! - fpoloop: do itb=itn+1,maxfpo + !---------------------------------------------------------------------------------! - !----- Updating the guess -----------------------------------------------------! - tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) - !----- Updating function evaluation -------------------------------------------! - pvap = eslif(tlcl,brrr_cold) - theta = tlcl * (es00/pvap)**rocp - funnow = thetaeivs(theta,tlcl,rtot,0.,0.) - theiv + !---------------------------------------------------------------------------------! + ! We have the guesses, solve the regula falsi method. ! + !---------------------------------------------------------------------------------! + fpoloop: do itb=itn+1,maxfpo + !----- Update guess and function evaluation. ----------------------------------! + tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) + pvap = eslif(tlcl,frozen) + funnow = tlcl * (es00/pvap)**rocp - thil + !------------------------------------------------------------------------------! !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=36,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & + !write (unit=21,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),3(a,1x,es11.4,1x))') & ! 'ANSWER: itb=',itn,'tlcl=',tlcl-t00,'eslcl=',0.01*pvap & - ! ,'thil=',thetaeiv2thil,'funa=',funa,'funz=',funz - !write (unit=36,fmt='(a)') '-------------------------------------------------------' - !write (unit=36,fmt='(a)') ' ' + ! ,'dzlcl=',dzlcl,'plcl=',plcl*0.01,'funa=',funa,'funz=',funz + !write (unit=21,fmt='(a)') '-------------------------------------------------------' + !write (unit=21,fmt='(a)') ' ' !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! else - write (unit=*,fmt='(60a1)') ('-',ii=1,60) - write (unit=*,fmt='(a)') ' THEIV2THIL failed!' - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' -> Input: ' - write (unit=*,fmt='(a,1x,f12.5)') ' THEIV [ K]:',theiv - write (unit=*,fmt='(a,1x,f12.5)') ' PRES [ Pa]:',pres * 100. - write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1000.*rtot - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' -> Output: ' - write (unit=*,fmt='(a,1x,i12)') ' ITERATIONS :',itb - write (unit=*,fmt='(a,1x,f12.5)') ' PVAP [ hPa]:',pvap - write (unit=*,fmt='(a,1x,f12.5)') ' THETA [ K]:',theta - write (unit=*,fmt='(a,1x,f12.5)') ' TLCL [ °C]:',tlcl-t00 - write (unit=*,fmt='(a,1x,f12.5)') ' TLCLA [ °C]:',tlcla-t00 - write (unit=*,fmt='(a,1x,f12.5)') ' TLCLZ [ °C]:',tlclz-t00 - write (unit=*,fmt='(a,1x,es12.5)') ' FUNA [ K]:',funa - write (unit=*,fmt='(a,1x,es12.5)') ' FUNZ [ K]:',funz - write (unit=*,fmt='(a,1x,es12.5)') ' DERIV [ ---]:',deriv - write (unit=*,fmt='(a,1x,es12.5)') ' ERR_A [ ---]:',abs(tlcl-tlcla)/tlcl - write (unit=*,fmt='(a,1x,es12.5)') ' ERR_Z [ ---]:',abs(tlcl-tlclz)/tlcl - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(60a1)') ('-',ii=1,60) - - call abort_run('TLCL didn''t converge, gave up!' & - ,'thetaeiv2thil','therm_lib.f90') + write (unit=*,fmt='(a)') '-------------------------------------------------------' + write (unit=*,fmt='(a)') ' LCL Temperature didn''t converge!!!' + write (unit=*,fmt='(a,1x,i5,1x,a)') ' I gave up, after',maxfpo,'iterations...' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Input values.' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a,1x,f12.4)' ) 'theta_il [ K] =',thil + write (unit=*,fmt='(a,1x,f12.4)' ) 'Pressure [ hPa] =',0.01*pres + write (unit=*,fmt='(a,1x,f12.4)' ) 'Temperature [ °C] =',temp-t00 + write (unit=*,fmt='(a,1x,f12.4)' ) 'rtot [ g/kg] =',1000.*rtot + write (unit=*,fmt='(a,1x,f12.4)' ) 'rvap [ g/kg] =',1000.*rvap + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' Last iteration outcome.' + write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcla [ °C] =',tlcla-t00 + write (unit=*,fmt='(a,1x,f12.4)' ) 'tlclz [ °C] =',tlclz-t00 + write (unit=*,fmt='(a,1x,f12.4)' ) 'fun [ K] =',funnow + write (unit=*,fmt='(a,1x,f12.4)' ) 'funa [ K] =',funa + write (unit=*,fmt='(a,1x,f12.4)' ) 'funz [ K] =',funz + write (unit=*,fmt='(a,1x,f12.4)' ) 'deriv [ ----] =',deriv + write (unit=*,fmt='(a,1x,es12.4)') 'toler [ ----] =',toler + write (unit=*,fmt='(a,1x,es12.4)') 'error [ ----] =' & + ,abs(tlclz-tlcla)/tlclz + write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcl [ °C] =',tlcl + call abort_run ('TLCL didn''t converge, gave up!','lcl_il','therm_lib.f90') end if - return - end function thetaeiv2thil + end subroutine lcl_il !=======================================================================================! !=======================================================================================! @@ -2555,137 +4325,317 @@ end function thetaeiv2thil !=======================================================================================! !=======================================================================================! - ! This subroutine converts saturated ice-vapour equivalent potential temperature ! - ! into temperature, given pressure in Pa, and theta_es in Kelvin. It also returns the ! - ! potential temperature in Kelvin, and saturation vapour mixing ratio in kg/kg. As ! - ! usual, we seek T using Newton's method as a starting point, and if it fails, we fall ! - ! back to the modified regula falsi (Illinois method). ! - ! ! - ! OBS: In case you want to ignore ice, send useice as false. The default is to consider ! - ! when level >= 3 and to ignore otherwise. ! + ! This subroutine computes a consistent set of temperature and condensated phases ! + ! mixing ratio for a given theta_il, Exner function, and total mixing ratio. This is ! + ! very similar to the function thil2temp, except that now we don't know rliq and rice, ! + ! and for this reason they also become functions of temperature, since they are defined ! + ! as rtot-rsat(T,p), remembering that rtot and p are known. If the air is not ! + ! saturated, we rather use the fact that theta_il = theta and skip the hassle. ! + ! Otherwise, we use iterative methods. We will always try Newton's method, since it ! + ! converges fast. The caveat is that Newton may fail, and it actually does fail very ! + ! close to the triple point, because the saturation vapour pressure function has a ! + ! "kink" at the triple point (continuous, but not differentiable). If that's the case, ! + ! then we fall back to a modified regula falsi (Illinois) method, which is a mix of ! + ! secant and bisection and will converge. ! !---------------------------------------------------------------------------------------! - subroutine thetaeivs2temp(theivs,pres,theta,temp,rsat,useice) - use rconstants, only : alvl,cp,ep,p00,rocp,ttripoli,t00 + subroutine thil2tqall(thil,exner,pres,rtot,rliq,rice,temp,rvap,rsat) + use rconstants , only : cpdry & ! intent(in) + , cpdryi & ! intent(in) + , t00 & ! intent(in) + , toodry & ! intent(in) + , t3ple ! ! intent(in) + implicit none - !----- Arguments --------------------------------------------------------------------! - real , intent(in) :: theivs ! Sat. thetae_iv [ K] - real , intent(in) :: pres ! Pressure [ Pa] - real , intent(out) :: theta ! Potential temperature [ K] - real , intent(out) :: temp ! Temperature [ K] - real , intent(out) :: rsat ! Saturation mixing ratio [ kg/kg] - logical, intent(in) , optional :: useice ! Flag for considering ice [ T|F] - !----- Local variables, with other thermodynamic properties -------------------------! - real :: exnernormi ! 1./ (Norm. Exner function) [ ---] - logical :: brrr_cold ! Flag for ice thermo [ T|F] - !----- Local variables for iterative method -----------------------------------------! - real :: deriv ! Function derivative - real :: funnow ! Function for which we seek a root. - real :: funa ! Smallest guess function - real :: funz ! Largest guess function - real :: tempa ! Smallest guess (or previous in Newton) - real :: tempz ! Largest guess (or new in Newton) - real :: delta ! Aux. variable for 2nd guess finding. - integer :: itn,itb ! Iteration counters - logical :: converged ! Convergence handle - logical :: zside ! Aux. flag, check sides (Regula Falsi) - !------------------------------------------------------------------------------------! - - !----- Setting up the ice check, in case useice is not present. ---------------------! - if (present(useice)) then - brrr_cold = useice - else - brrr_cold = bulk_on + !----- Arguments. -------------------------------------------------------------------! + real(kind=4), intent(in) :: thil ! Ice-liquid water potential temp. [ K] + real(kind=4), intent(in) :: exner ! Exner function [J/kg/K] + real(kind=4), intent(in) :: pres ! Pressure [ Pa] + real(kind=4), intent(in) :: rtot ! Total mixing ratio [ kg/kg] + real(kind=4), intent(out) :: rliq ! Liquid water mixing ratio [ kg/kg] + real(kind=4), intent(out) :: rice ! Ice mixing ratio [ kg/kg] + real(kind=4), intent(inout) :: temp ! Temperature [ K] + real(kind=4), intent(out) :: rvap ! Water vapour mixing ratio [ kg/kg] + real(kind=4), intent(out) :: rsat ! Sat. water vapour mixing ratio [ kg/kg] + !----- Local variables --------------------------------------------------------------! + real(kind=4) :: tempa ! Lower bound for regula falsi iteration + real(kind=4) :: tempz ! Upper bound for regula falsi iteration + real(kind=4) :: t1stguess ! Book keeping temperature 1st guess + real(kind=4) :: fun1st ! Book keeping 1st guess function + real(kind=4) :: funa ! Function evaluation at tempa + real(kind=4) :: funz ! Function evaluation at tempz + real(kind=4) :: funnow ! Function at this iteration. + real(kind=4) :: delta ! Aux. var in case we need regula falsi. + real(kind=4) :: deriv ! Derivative of this function. + integer :: itn ! Iteration counter + integer :: itb ! Iteration counter + integer :: ii ! Iteration counter + logical :: converged ! Convergence handle + logical :: zside ! Aux. Flag, for two purposes: + ! 1. Found a 2nd guess for regula falsi. + ! 2. I retained the "zside" (T/F) + !------------------------------------------------------------------------------------! + + t1stguess = temp + + !------------------------------------------------------------------------------------! + ! First check: try to find temperature assuming sub-saturation and check if ! + ! this is the case. If it is, then there is no need to go through the iterative ! + ! loop. ! + !------------------------------------------------------------------------------------! + tempz = cpdryi * thil * exner + rsat = max(toodry,rslif(pres,tempz)) + if (tempz >= t3ple) then + rliq = max(0.,rtot-rsat) + rice = 0. + else + rice = max(0.,rtot-rsat) + rliq = 0. end if - - !----- Finding the inverse of normalised Exner, which is constant in this routine ---! - exnernormi = (p00 /pres) ** rocp + rvap = rtot-rliq-rice + !------------------------------------------------------------------------------------! !------------------------------------------------------------------------------------! - ! The 1st. guess, no idea, guess 0°C. ! + ! If rtot < rsat, this is not saturated, we can leave the subroutine and bypass ! + ! the iterative part. ! !------------------------------------------------------------------------------------! - tempz = t00 - theta = tempz * exnernormi - rsat = rslif(pres,tempz,brrr_cold) - funnow = thetaeivs(theta,tempz,rsat,0.,0.) - deriv = dthetaeivs_dt(funnow,tempz,pres,rsat,brrr_cold) - funnow = funnow - theivs + if (rtot < rsat) then + temp = tempz + return + end if - !----- Saving here just in case Newton is aborted at the 1st guess ------------------! - tempa = tempz - funa = funnow + !------------------------------------------------------------------------------------! + ! If not, then use the temperature the user gave as first guess and solve ! + ! iteratively. We use the user instead of what we just found because if the air is ! + ! saturated, then this can be too far off which may be bad for Newton's method. ! + !------------------------------------------------------------------------------------! + tempz = temp + rsat = max(toodry,rslif(pres,tempz)) + if (tempz >= t3ple) then + rliq = max(0.,rtot-rsat) + rice = 0. + else + rice = max(0.,rtot-rsat) + rliq = 0. + end if + rvap = rtot-rliq-rice - converged = .false. - !----- Looping ----------------------------------------------------------------------! + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>= t3ple) then + rliq = max(0.,rtot-rsat) + rice = 0. + else + rice = max(0.,rtot-rsat) + rliq = 0. + end if + rvap = rtot-rliq-rice + !----- Updating the function -----------------------------------------------------! + funnow = theta_iceliq(exner,tempz,rliq,rice) + !----- Updating the derivative. --------------------------------------------------! + deriv = dthetail_dt(.false.,funnow,exner,pres,tempz,rliq,rice) + funnow = funnow - thil + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !write (unit=46,fmt='(a,1x,i5,1x,6(a,1x,f11.4,1x),a,1x,es11.4,1x)') & + ! 'NEWTON: it=',itn,'temp=',tempz-t00,'rsat=',1000.*rsat,'rliq=',1000.*rliq & + ! ,'rice=',1000.*rice,'rvap=',1000.*rvap,'fun=',funnow,'deriv=',deriv + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + converged = abs(tempa-tempz) < toler*tempz + !---------------------------------------------------------------------------------! + ! Convergence. The temperature will be the mid-point between tempa and tempz. ! + ! Fix the mixing ratios and return. But first check for converged due to luck. If ! + ! the guess gives a root, then that's it. It looks unlikely, but it actually ! + ! happens sometimes and if not checked it becomes a singularity. ! + !---------------------------------------------------------------------------------! if (funnow == 0.) then - converged =.true. temp = tempz + converged = .true. exit newloop elseif (converged) then - temp = 0.5*(tempa+tempz) + temp = 0.5 * (tempa+tempz) + rsat = max(toodry,rslif(pres,temp)) + if (temp >= t3ple) then + rliq = max(0.,rtot-rsat) + rice = 0. + else + rice = max(0.,rtot-rsat) + rliq = 0. + end if + rvap = rtot-rliq-rice exit newloop end if - end do newloop + end do newloop !------------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using bisec- ! - ! tion instead. ! - !------------------------------------------------------------------------------------! + + !----- For debugging only -----------------------------------------------------------! + itb = itn+1 + if (.not. converged) then - !----- Set funz, and check whether funa and funz already have opposite sign. -----! - funz = funnow - zside = .false. - if (funa*funnow > 0.) then - !----- We fix funa, and try a funz that will work as 2nd guess ----------------! - if (abs(funz-funa) < toler*tempa) then + !---------------------------------------------------------------------------------! + ! If I reach this point, then it means that Newton's method failed finding the ! + ! equilibrium, so we are going to use the regula falsi instead. If Newton's ! + ! method didn't converge, we use tempa as one guess and now we seek a tempz with ! + ! opposite sign. ! + !---------------------------------------------------------------------------------! + !----- Check funa and funnow have opposite signs. If so, we are ready to go ------! + if (funa*funnow < 0.0) then + funz = funnow + zside = .true. + !----- Otherwise, checking whether the 1st guess had opposite sign. --------------! + elseif (funa*fun1st < 0.0) then + funz = fun1st + zside = .true. + !---------------------------------------------------------------------------------! + ! Looking for a guess. Extrapolate funa linearly, trying to get the -funa. We ! + ! don't need it to be funa, just with the opposite sign. If that's not enough, ! + ! we keep going further... Force the guesses to be at least 1K apart ! + !---------------------------------------------------------------------------------! + else + if (abs(funnow-funa) < 100.*toler*tempa) then delta = 100.*toler*tempa else - delta = max(abs(funa*(tempz-tempa)/(funz-funa)),100.*toler*tempa) + delta = max(abs(funa)*abs((tempz-tempa)/(funnow-funa)),100.*toler*tempa) end if tempz = tempa + delta + funz = funa + !----- Just to enter at least once. The 1st time tempz=tempa-2*delta ----------! + zside = .false. zgssloop: do itb=1,maxfpo - !----- So this will be +1 -1 +2 -2 etc. ------------------------------------! - tempz = tempz + real((-1)**itb * (itb+3)/2) * delta - theta = tempz * exnernormi - rsat = rslif(pres,tempz,brrr_cold) - funz = thetaeivs(theta,tempz,rsat,0.,0.) - theivs - zside = funa*funz < 0 - if (zside) exit zgssloop + tempz = tempa + real((-1)**itb * (itb+3)/2) * delta + rsat = max(toodry,rslif(pres,tempz)) + if (tempz >= t3ple) then + rliq = max(0.,rtot-rsat) + rice = 0. + else + rice = max(0.,rtot-rsat) + rliq = 0. + end if + rvap = rtot-rliq-rice + funz = theta_iceliq(exner,tempz,rliq,rice) - thil + zside = funa*funz < 0.0 + if (zside) exit zgssloop end do zgssloop - if (.not. zside) & - call abort_run('Failed finding the second guess for regula falsi' & - ,'thetaes2temp','therm_lib.f90') + if (.not. zside) then + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + write (unit=*,fmt='(a)') ' THIL2TQALL: NO SECOND GUESS FOR YOU!' + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Input: ' + write (unit=*,fmt='(a,1x,f12.5)') ' THETA_IL [ K]:',thil + write (unit=*,fmt='(a,1x,f12.5)') ' PRESS [ hPa]:',0.01*pres + write (unit=*,fmt='(a,1x,f12.5)') ' EXNER [J/kg/K]:',exner + write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1000.*rtot + write (unit=*,fmt='(a,1x,f12.5)') ' T1ST [ degC]:',t1stguess-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPA [ degC]:',tempa-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPZ [ degC]:',tempz-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' FUNNOW [ K]:',funnow + write (unit=*,fmt='(a,1x,f12.5)') ' FUNA [ K]:',funa + write (unit=*,fmt='(a,1x,f12.5)') ' FUNZ [ K]:',funz + write (unit=*,fmt='(a,1x,f12.5)') ' DELTA [ K]:',delta + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + + call abort_run ('Failed finding the second guess for regula falsi' & + ,'thil2tqall','therm_lib.f90') + end if end if - !---- Continue iterative method --------------------------------------------------! - fpoloop: do itb=itn+1,maxfpo - if (abs(funz-funa) < toler*tempa) then - temp = 0.5*(tempa+tempz) + !---------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------! + ! Now we loop until convergence is achieved. One important thing to notice ! + ! is that Newton's method fail only when T is almost T3ple, which means that ice ! + ! and liquid should be present, and we are trying to find the saturation point ! + ! with all ice or all liquid. This will converge but the final answer will ! + ! contain significant error. To reduce it we redistribute the condensates between ! + ! ice and liquid conserving the total condensed mixing ratio. ! + !---------------------------------------------------------------------------------! + fpoloop: do itb=itn,maxfpo + temp = (funz*tempa-funa*tempz)/(funz-funa) + !----- Checking whether this guess will fall outside the range ----------------! + if (abs(temp-tempa) > abs(tempz-tempa) .or. & + abs(temp-tempz) > abs(tempz-tempa)) then + temp = 0.5*(tempa+tempz) + end if + !----- Distributing vapour into the three phases ------------------------------! + rsat = max(toodry,rslif(pres,temp)) + rvap = min(rtot,rsat) + if (temp >= t3ple) then + rliq = max(0.,rtot-rsat) + rice = 0. else - temp = (funz*tempa-funa*tempz)/(funz-funa) + rliq = 0. + rice = max(0.,rtot-rsat) end if - theta = temp * exnernormi - rsat = rslif(pres,temp,brrr_cold) - funnow = thetaeivs(theta,temp,rsat,0.,0.) - theivs + !----- Updating function ------------------------------------------------------! + funnow = theta_iceliq(exner,temp,rliq,rice) - thil + + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> Input: ' + write (unit=*,fmt='(a,1x,f12.5)') ' THETA_IL [ K]:',thil + write (unit=*,fmt='(a,1x,f12.5)') ' EXNER [J/kg/K]:',exner + write (unit=*,fmt='(a,1x,f12.5)') ' RTOT [ g/kg]:',1000.*rtot + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(a)') ' -> Output: ' + write (unit=*,fmt='(a,1x,i12)') ' ITERATIONS :',itb + write (unit=*,fmt='(a,1x,f12.5)') ' TEMP [ °C]:',temp-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' RVAP [ g/kg]:',1000.*rvap + write (unit=*,fmt='(a,1x,f12.5)') ' RLIQ [ g/kg]:',1000.*rliq + write (unit=*,fmt='(a,1x,f12.5)') ' RICE [ g/kg]:',1000.*rice + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPA [ °C]:',tempa-t00 + write (unit=*,fmt='(a,1x,f12.5)') ' TEMPZ [ °C]:',tempz-t00 + write (unit=*,fmt='(a,1x,es12.5)') ' FUNA [ K]:',funnow + write (unit=*,fmt='(a,1x,es12.5)') ' FUNZ [ K]:',funnow + write (unit=*,fmt='(a,1x,es12.5)') ' DERIV [ ---]:',deriv + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_A [ ---]:',abs(temp-tempa)/temp + write (unit=*,fmt='(a,1x,es12.5)') ' ERR_Z [ ---]:',abs(temp-tempz)/temp + write (unit=*,fmt='(a)') ' ' + write (unit=*,fmt='(60a1)') ('-',ii=1,60) + call abort_run ('Failed finding equilibrium, I gave up!','thil2tqall' & + ,'therm_lib.f90') + end if + !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & - ! 'NEWTON: it=',itn,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funnow & - ! ,'deriv=',deriv - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! + !----- Go to bisection if the derivative is too flat (too dangerous...) ----------! + if (abs(deriv) < toler) exit newloop - !------------------------------------------------------------------------------! - ! Convergence may happen when we get close guesses. ! - !------------------------------------------------------------------------------! - converged = abs(tlcla-tlclz) < toler*tlclz - if (converged) then - tlcl = 0.5*(tlcla+tlclz) - funz = funnow - exit newloop - elseif (funnow == 0.) then - tlcl = tlclz - funz = funnow + tempz = tempa - funnow / deriv + + !----- Finding the mixing ratios associated with this guess ----------------------! + rsat = max(toodry,rslf(pres,tempz)) + rliq = max(0.,rtot-rsat) + rvap = rtot-rliq + + !----- Updating the function -----------------------------------------------------! + funnow = theta_iceliq(exner,tempz,rliq,0.) + !----- Updating the derivative. --------------------------------------------------! + deriv = dthetail_dt(.false.,funnow,exner,pres,tempz,rliq) + funnow = funnow - thil + + converged = abs(tempa-tempz) < toler*tempz + !---------------------------------------------------------------------------------! + ! Convergence. The temperature will be the mid-point between tempa and tempz. ! + ! Fix the mixing ratios and return. But first check for converged due to luck. If ! + ! the guess gives a root, then that's it. It looks unlikely, but it actually ! + ! happens sometimes and if not checked it becomes a singularity. ! + !---------------------------------------------------------------------------------! + if (funnow == 0.) then + temp = tempz converged = .true. exit newloop + elseif (converged) then + temp = 0.5 * (tempa+tempz) + rsat = max(toodry,rslf(pres,temp)) + rliq = max(0.,rtot-rsat) + rvap = rtot-rliq + exit newloop end if + !---------------------------------------------------------------------------------! end do newloop + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! if (.not. converged) then !---------------------------------------------------------------------------------! - ! If I reached this point then it's because Newton's method failed. Using re- ! - ! gula falsi instead. First, I need to find two guesses that give me functions ! - ! with opposite signs. If funa and funnow have opposite signs, then we are all ! - ! set. ! + ! If I reach this point, then it means that Newton's method failed finding the ! + ! equilibrium, so we are going to use the regula falsi instead. If Newton's ! + ! method didn't converge, we use tempa as one guess and now we seek a tempz with ! + ! opposite sign. ! !---------------------------------------------------------------------------------! - if (funa*funnow < 0. ) then - funz = funnow + !----- Check funa and funnow have opposite signs. If so, we are ready to go ------! + if (funa*funnow < 0.0) then + funz = funnow zside = .true. - !----- They have the same sign, seeking the other guess --------------------------! + !---------------------------------------------------------------------------------! + ! Looking for a guess. Extrapolate funa linearly, trying to get the -funa. We ! + ! don't need it to be funa, just with the opposite sign. If that's not enough, ! + ! we keep going further... Force the guesses to be at least 1K apart ! + !---------------------------------------------------------------------------------! else - - !----- We fix funa, and try a funz that will work as 2nd guess ----------------! - if (abs(funnow-funa) < toler*tlcla) then - delta = 100.*toler*tlcla + if (abs(funnow-funa) < toler*tempa) then + delta = 100.*toler*tempa else - delta = max(abs(funa*(tlclz-tlcla)/(funnow-funa)),100.*toler*tlcla) + delta = max(abs(funa*(tempz-tempa)/(funnow-funa)),100.*toler*tempa) end if - tlclz = tlcla + delta - - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=21,fmt='(a,1x,i5,1x,2(a,1x,f11.4,1x),2(a,1x,es11.4,1x))') & - ! '2NGGSS: tt=',itb,'tlclz=',tlclz-t00,'pvap=',0.01*pvap,'fun=',funz & - ! ,'delta=',delta - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - zside = funa*funz < 0 + tempz = tempz + real((-1)**itb * (itb+3)/2) * delta + rsat = max(toodry,rslf(pres,tempz)) + rliq = max(0.,rtot-rsat) + rvap = rtot-rliq + funz = theta_iceliq(exner,tempz,rliq,0.) - thil + zside = funa*funz < 0.0 if (zside) exit zgssloop end do zgssloop - if (.not. zside) then - write (unit=*,fmt='(a)') ' ====== No second guess for you... ======' - write (unit=*,fmt='(a)') ' + INPUT variables: ' - write (unit=*,fmt='(a,1x,es14.7)') 'THIL =',thil - write (unit=*,fmt='(a,1x,es14.7)') 'TEMP =',temp - write (unit=*,fmt='(a,1x,es14.7)') 'PRES =',pres - write (unit=*,fmt='(a,1x,es14.7)') 'RTOT =',rtot - write (unit=*,fmt='(a,1x,es14.7)') 'RVAP =',rvap - write (unit=*,fmt='(a,1x,i5)') 'CALL =',iflg - write (unit=*,fmt='(a)') ' ============ Failed guess... ===========' - write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLA =',tlcla,'FUNA =',funa - write (unit=*,fmt='(2(a,1x,es14.7))') 'TLCLZ =',tlclz,'FUNC =',funz - write (unit=*,fmt='(2(a,1x,es14.7))') 'DELTA =',delta,'FUNN =',funnow - call abort_run('Failed finding the second guess for regula falsi' & - ,'lcl_il','therm_lib.f90') - end if + if (.not. zside) & + call abort_run ('Failed finding the second guess for regula falsi' & + ,'thil2tqliq','rthrm.f90') end if - !---- Continue iterative method --------------------------------------------------! - fpoloop: do itb=itn+1,maxfpo - - tlcl = (funz*tlcla-funa*tlclz)/(funz-funa) - - pvap = eslif(tlcl,brrr_cold) - - funnow = tlcl * (es00/pvap)**rocp - thil + !---------------------------------------------------------------------------------! - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - !write (unit=21,fmt='(a,1x,i5,1x,3(a,1x,f11.4,1x),3(a,1x,es11.4,1x))') & - ! 'ANSWER: itb=',itn,'tlcl=',tlcl-t00,'eslcl=',0.01*pvap & - ! ,'dzlcl=',dzlcl,'plcl=',plcl*0.01,'funa=',funa,'funz=',funz - !write (unit=21,fmt='(a)') '-------------------------------------------------------' - !write (unit=21,fmt='(a)') ' ' - !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>! - else - write (unit=*,fmt='(a)') '-------------------------------------------------------' - write (unit=*,fmt='(a)') ' LCL Temperature didn''t converge!!!' - write (unit=*,fmt='(a,1x,i5,1x,a)') ' I gave up, after',maxfpo,'iterations...' - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' Input values.' - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a,1x,f12.4)' ) 'theta_il [ K] =',thil - write (unit=*,fmt='(a,1x,f12.4)' ) 'Pressure [ hPa] =',0.01*pres - write (unit=*,fmt='(a,1x,f12.4)' ) 'Temperature [ °C] =',temp-t00 - write (unit=*,fmt='(a,1x,f12.4)' ) 'rtot [ g/kg] =',1000.*rtot - write (unit=*,fmt='(a,1x,f12.4)' ) 'rvap [ g/kg] =',1000.*rvap - write (unit=*,fmt='(a,1x,i5)' ) 'call [ ---] =',iflg - write (unit=*,fmt='(a)') ' ' - write (unit=*,fmt='(a)') ' Last iteration outcome.' - write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcla [ °C] =',tlcla-t00 - write (unit=*,fmt='(a,1x,f12.4)' ) 'tlclz [ °C] =',tlclz-t00 - write (unit=*,fmt='(a,1x,f12.4)' ) 'fun [ K] =',funnow - write (unit=*,fmt='(a,1x,f12.4)' ) 'funa [ K] =',funa - write (unit=*,fmt='(a,1x,f12.4)' ) 'funz [ K] =',funz - write (unit=*,fmt='(a,1x,f12.4)' ) 'deriv [ ----] =',deriv - write (unit=*,fmt='(a,1x,es12.4)') 'toler [ ----] =',toler - write (unit=*,fmt='(a,1x,es12.4)') 'error [ ----] =' & - ,abs(tlclz-tlcla)/tlclz - write (unit=*,fmt='(a,1x,f12.4)' ) 'tlcl [ °C] =',tlcl - call abort_run('TLCL didn''t converge, gave up!','lcl_il','therm_lib.f90') - end if + + if (.not. converged) call abort_run ('Failed finding equilibrium, I gave up!' & + ,'thil2tqliq','therm_lib.f90') return - end subroutine lcl_il + end subroutine thil2tqliq !=======================================================================================! !=======================================================================================! @@ -3031,35 +4982,48 @@ end subroutine lcl_il !=======================================================================================! !=======================================================================================! ! This subroutine computes the temperature and fraction of liquid water from the ! - ! internal energy . ! + ! intensive internal energy [J/kg]. ! !---------------------------------------------------------------------------------------! - subroutine qtk(q,tempk,fracliq) - use rconstants, only: cliqi,cicei,allii,t3ple,qicet3,qliqt3,tsupercool + subroutine uint2tl(uint,temp,fliq) + use rconstants , only : cliqi & ! intent(in) + , cicei & ! intent(in) + , allii & ! intent(in) + , t3ple & ! intent(in) + , uiicet3 & ! intent(in) + , uiliqt3 & ! intent(in) + , tsupercool_liq ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: q ! Internal energy [ J/kg] - real, intent(out) :: tempk ! Temperature [ K] - real, intent(out) :: fracliq ! Liquid Fraction (0-1) [ ---] + real(kind=4), intent(in) :: uint ! Internal energy [ J/kg] + real(kind=4), intent(out) :: temp ! Temperature [ K] + real(kind=4), intent(out) :: fliq ! Liquid Fraction (0-1) [ ---] !------------------------------------------------------------------------------------! - !----- Internal energy below qwfroz, all ice ---------------------------------------! - if (q <= qicet3) then - fracliq = 0. - tempk = q * cicei - !----- Internal energy, above qwmelt, all liquid ------------------------------------! - elseif (q >= qliqt3) then - fracliq = 1. - tempk = q * cliqi + tsupercool - !----- Changing phase, it must be at freezing point ---------------------------------! + !------------------------------------------------------------------------------------! + ! Compare the internal energy with the reference values to decide which phase ! + ! the water is. ! + !------------------------------------------------------------------------------------! + if (uint <= uiicet3) then + !----- Internal energy below qwfroz, all ice ------------------------------------! + fliq = 0. + temp = uint * cicei + !---------------------------------------------------------------------------------! + elseif (uint >= uiliqt3) then + !----- Internal energy, above qwmelt, all liquid ---------------------------------! + fliq = 1. + temp = uint * cliqi + tsupercool_liq + !---------------------------------------------------------------------------------! else - fracliq = (q-qicet3) * allii - tempk = t3ple - endif + !----- Changing phase, it must be at freezing point ------------------------------! + fliq = (uint - uiicet3) * allii + temp = t3ple + !---------------------------------------------------------------------------------! + end if !------------------------------------------------------------------------------------! return - end subroutine qtk + end subroutine uint2tl !=======================================================================================! !=======================================================================================! @@ -3070,64 +5034,78 @@ end subroutine qtk !=======================================================================================! !=======================================================================================! - ! This subroutine computes the temperature (Kelvin) and liquid fraction from inter- ! - ! nal energy (J/m² or J/m³), mass (kg/m² or kg/m³), and heat capacity (J/m²/K or ! - ! J/m³/K). ! + ! This subroutine computes the temperature (Kelvin) and liquid fraction from ! + ! extensive internal energy (J/m² or J/m³), water mass (kg/m² or kg/m³), and heat ! + ! capacity (J/m²/K or J/m³/K). ! !---------------------------------------------------------------------------------------! - subroutine qwtk(qw,w,dryhcap,tempk,fracliq) - use rconstants, only: cliqi,cliq,cicei,cice,allii,alli,t3ple,tsupercool + subroutine uextcm2tl(uext,wmass,dryhcap,temp,fliq) + use rconstants , only : cliqi & ! intent(in) + , cliq & ! intent(in) + , cicei & ! intent(in) + , cice & ! intent(in) + , allii & ! intent(in) + , alli & ! intent(in) + , t3ple & ! intent(in) + , tsupercool_liq ! ! intent(in) implicit none !----- Arguments --------------------------------------------------------------------! - real, intent(in) :: qw ! Internal energy [ J/m²] or [ J/m³] - real, intent(in) :: w ! Density [ kg/m²] or [ kg/m³] - real, intent(in) :: dryhcap ! Heat capacity of nonwater part [J/m²/K] or [J/m³/K] - real, intent(out) :: tempk ! Temperature [ K] - real, intent(out) :: fracliq ! Liquid fraction (0-1) [ ---] + real(kind=4), intent(in) :: uext ! Extensive internal energy [ J/m²] or [ J/m³] + real(kind=4), intent(in) :: wmass ! Water mass [ kg/m²] or [ kg/m³] + real(kind=4), intent(in) :: dryhcap ! Heat cap. of "dry" part [J/m²/K] or [J/m³/K] + real(kind=4), intent(out) :: temp ! Temperature [ K] + real(kind=4), intent(out) :: fliq ! Liquid fraction (0-1) [ ---] !----- Local variable ---------------------------------------------------------------! - real :: qwfroz ! qw of ice at triple point [ J/m²] or [ J/m³] - real :: qwmelt ! qw of liquid at triple point [ J/m²] or [ J/m³] + real(kind=4) :: uefroz ! qw of ice at triple pt. [ J/m²] or [ J/m³] + real(kind=4) :: uemelt ! qw of liq. at triple pt. [ J/m²] or [ J/m³] !------------------------------------------------------------------------------------! - !----- Converting melting heat to J/m² or J/m³ --------------------------------------! - qwfroz = (dryhcap + w*cice) * t3ple - qwmelt = qwfroz + w*alli - !------------------------------------------------------------------------------------! - - !------------------------------------------------------------------------------------! - ! This is analogous to the qtk computation, we should analyse the magnitude of ! - ! the internal energy to choose between liquid, ice, or both by comparing with our. ! - ! know boundaries. ! - !------------------------------------------------------------------------------------! - !----- Internal energy below qwfroz, all ice ---------------------------------------! - if (qw < qwfroz) then - fracliq = 0. - tempk = qw / (cice * w + dryhcap) - !----- Internal energy, above qwmelt, all liquid ------------------------------------! - elseif (qw > qwmelt) then - fracliq = 1. - tempk = (qw + w * cliq * tsupercool) / (dryhcap + w*cliq) - !------------------------------------------------------------------------------------! - ! We are at the freezing point. If water mass is so tiny that the internal ! - ! energy of frozen and melted states are the same given the machine precision, then ! - ! we assume that water content is negligible and we impose 50% frozen for ! - ! simplicity. ! + + !----- Convert melting heat to J/m² or J/m³ -----------------------------------------! + uefroz = (dryhcap + wmass * cice) * t3ple + uemelt = uefroz + wmass * alli !------------------------------------------------------------------------------------! - elseif (qwfroz == qwmelt) then - fracliq = 0.5 - tempk = t3ple + + + !------------------------------------------------------------------------------------! - ! Changing phase, it must be at freezing point. The max and min are here just to ! - ! avoid tiny deviations beyond 0. and 1. due to floating point arithmetics. ! + ! This is analogous to the uint2tl computation, we should analyse the magnitude ! + ! of the internal energy to choose between liquid, ice, or both by comparing with ! + ! the known boundaries. ! !------------------------------------------------------------------------------------! + if (uext < uefroz) then + !----- Internal energy below qwfroz, all ice ------------------------------------! + fliq = 0. + temp = uext / (cice * wmass + dryhcap) + !---------------------------------------------------------------------------------! + elseif (uext > uemelt) then + !----- Internal energy, above qwmelt, all liquid ---------------------------------! + fliq = 1. + temp = (uext + wmass * cliq * tsupercool_liq) / (dryhcap + wmass * cliq) + !---------------------------------------------------------------------------------! + elseif (uefroz == uemelt) then + !---------------------------------------------------------------------------------! + ! We are at the freezing point. If water mass is so tiny that the internal ! + ! energy of frozen and melted states are the same given the machine precision, ! + ! then we assume that water content is negligible and we impose 50% frozen for ! + ! simplicity. ! + !---------------------------------------------------------------------------------! + fliq = 0.5 + temp = t3ple + !---------------------------------------------------------------------------------! else - fracliq = min(1.,max(0.,(qw - qwfroz) * allii / w)) - tempk = t3ple + !---------------------------------------------------------------------------------! + ! Changing phase, it must be at freezing point. The max and min are here just ! + ! to avoid tiny deviations beyond 0. and 1. due to floating point arithmetics. ! + !---------------------------------------------------------------------------------! + fliq = min(1.,max(0.,(uext - uefroz) * allii / wmass)) + temp = t3ple + !---------------------------------------------------------------------------------! end if !------------------------------------------------------------------------------------! return - end subroutine qwtk + end subroutine uextcm2tl !=======================================================================================! !=======================================================================================! end module therm_lib diff --git a/Ramspost/src/memory/rconstants.f90 b/Ramspost/src/memory/rconstants.f90 index fd987903b..a6ce06241 100644 --- a/Ramspost/src/memory/rconstants.f90 +++ b/Ramspost/src/memory/rconstants.f90 @@ -25,6 +25,7 @@ Module rconstants real, parameter :: sqrtpii = 0.564189583547756 ! 1/(pi**0.5) [ ---] real, parameter :: sqrthalfpi = 1.2533141373155 ! (pi/2)**0.5 [ ---] real, parameter :: sqrttwopi = 2. * sqrthalfpi ! (2*pi)**0.5 [ ---] + real, parameter :: euler_gam = 0.577215664901533 ! Euler's constant [ ---] !---------------------------------------------------------------------------------------! @@ -78,6 +79,7 @@ Module rconstants real, parameter :: mmdry1000 = 1000.*mmdry ! Mean dry air molar mass [ kg/mol] real, parameter :: mmcod1em6 = mmcod * 1.e-6 ! Convert ppm to kgCO2/kgair [ ----] real, parameter :: mmdryi = 1./mmdry ! 1./mmdry [ mol/kg] + real, parameter :: mmh2oi = 1./mmh2o ! 1./mmdry [ mol/kg] real, parameter :: mmco2i = 1./mmco2 ! 1./mmco2 [ mol/kg] !---------------------------------------------------------------------------------------! @@ -89,6 +91,7 @@ Module rconstants real, parameter :: day_sec = 86400. ! # of seconds in a day [ s/day] real, parameter :: day_hr = 24. ! # of hours in a day [ hr/day] real, parameter :: hr_sec = 3600. ! # of seconds in an hour [ s/hr] + real, parameter :: hr_min = 60. ! # of minutes in an hour [ min/hr] real, parameter :: min_sec = 60. ! # of seconds in a minute [ s/min] real, parameter :: yr_sec = yr_day * day_sec ! # of seconds in a year [ s/yr] !---------------------------------------------------------------------------------------! @@ -118,24 +121,54 @@ Module rconstants + !---------------------------------------------------------------------------------------! + ! Reference for this block: ! + ! MU08 - Monteith, J. L., M. H. Unsworth, 2008. Principles of Environmental Physics, ! + ! third edition, Academic Press, Amsterdam, 418pp. (Chapters 3 and 10). ! + ! ! + ! Air diffusion properties. These properties are temperature-dependent in reality, ! + ! but for simplicity we assume them constants, using the value at 20°C. ! + ! ! + ! Thermal diffusivity - Straight from Table 15.1 of MU08 ! + ! Kinematic viscosity - Computed from equation on page 32 of MU08; ! + ! Thermal expansion coefficient - determined by inverting the coefficient at equation ! + ! 10.11 (MU08). ! + ! These terms could be easily made function of temperature in the future if needed be. ! + !---------------------------------------------------------------------------------------! + real, parameter :: th_diff = 2.060e-5 ! Air thermal diffusivity [ m²/s] + real, parameter :: th_diffi = 1./th_diff ! 1/ air thermal diffusivity [ s/m²] + real, parameter :: kin_visc = 1.516e-5 ! Kinematic viscosity [ m²/s] + real, parameter :: kin_visci = 1./kin_visc ! 1/Kinematic viscosity [ s/m²] + real, parameter :: th_expan = 3.43e-3 ! Air thermal expansion coeff. [ 1/K] + !---------------------------------------------------------------------------------------! + ! Grashof coefficient [1/(K m³)]. This is the coefficient a*g/(nu²) in MU08's ! + ! equation 10.8, in the equation that defines the Grashof number. ! + !---------------------------------------------------------------------------------------! + real, parameter :: gr_coeff = th_expan * grav * kin_visci * kin_visci + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! ! Dry air properties ! !---------------------------------------------------------------------------------------! - real, parameter :: rdry = rmol/mmdry ! Gas constant for dry air (Ra) [ J/kg/K] - real, parameter :: rdryi = mmdry/rmol ! 1./Gas constant for dry air (Ra) [ kg K/J] - real, parameter :: cp = 3.5 * rdry ! Specific heat at constant press. [ J/kg/K] - real, parameter :: cv = 2.5 * rdry ! Specific heat at constant volume [ J/kg/K] - real, parameter :: cpog = cp /grav ! cp/g [ m/K] - real, parameter :: rocp = rdry / cp ! Ra/cp [ ----] - real, parameter :: rocv = rdry / cv ! Ra/Cv [ ----] - real, parameter :: cpocv = cp / cv ! Cp/Cv [ ----] - real, parameter :: cpor = cp / rdry ! Cp/Ra [ ----] - real, parameter :: gocp = grav / cp ! g/Cp, dry adiabatic lapse rate [ K/m] - real, parameter :: gordry = grav / rdry ! g/Ra [ K/m] - real, parameter :: cpi = 1. / cp ! 1/Cp [ kg K/J] - real, parameter :: cpi4 = 4. * cpi ! 4/Cp [ kg K/J] - real, parameter :: p00k = 26.8269579527 ! p0 ** (Ra/Cp) [ Pa^2/7] - real, parameter :: p00ki = 1. / p00k ! p0 ** (-Ra/Cp) [ Pa^-2/7] + real, parameter :: rdry = rmol/mmdry ! Gas constant for dry air (Ra) [ J/kg/K] + real, parameter :: rdryi = mmdry/rmol ! 1./Gas const. for dry air (Ra) [ kg K/J] + real, parameter :: cpdry = 3.5 * rdry ! Spec. heat at constant press. [ J/kg/K] + real, parameter :: cvdry = 2.5 * rdry ! Spec. heat at constant volume [ J/kg/K] + real, parameter :: cpog = cpdry /grav ! cp/g [ m/K] + real, parameter :: rocp = rdry / cpdry ! Ra/cp [ ----] + real, parameter :: rocv = rdry / cvdry ! Ra/Cv [ ----] + real, parameter :: cpocv = cpdry / cvdry ! Cp/Cv [ ----] + real, parameter :: cpor = cpdry / rdry ! Cp/Ra [ ----] + real, parameter :: cvor = cvdry / rdry ! Cp/Ra [ ----] + real, parameter :: gocp = grav / cpdry ! g/Cp, dry adiabatic lapse rate [ K/m] + real, parameter :: gordry = grav / rdry ! g/Ra [ K/m] + real, parameter :: cpdryi = 1. / cpdry ! 1/Cp [ kg K/J] + real, parameter :: cpdryi4 = 4. * cpdryi ! 4/Cp [ kg K/J] + real, parameter :: p00or = p00 / rdry ! p0 ** (Ra/Cp) [ Pa^2/7] + real, parameter :: p00k = 26.8269579527 ! p0 ** (Ra/Cp) [ Pa^2/7] + real, parameter :: p00ki = 1. / p00k ! p0 ** (-Ra/Cp) [ Pa^-2/7] !---------------------------------------------------------------------------------------! @@ -144,11 +177,13 @@ Module rconstants ! Water vapour properties ! !---------------------------------------------------------------------------------------! real, parameter :: rh2o = rmol/mmh2o ! Gas const. for water vapour (Rv) [ J/kg/K] + real, parameter :: cph2o = 1859. ! Heat capacity at const. pres. [ J/kg/K] + real, parameter :: cph2oi = 1. / cph2o ! Inverse of heat capacity [ kg K/J] + real, parameter :: cvh2o = cph2o-rh2o ! Heat capacity at const. volume [ J/kg/K] real, parameter :: gorh2o = grav / rh2o ! g/Rv [ K/m] real, parameter :: ep = mmh2o/mmdry ! or Ra/Rv, epsilon [ kg/kg] real, parameter :: epi = mmdry/mmh2o ! or Rv/Ra, 1/epsilon [ kg/kg] real, parameter :: epim1 = epi-1. ! that 0.61 term of virtual temp. [ kg/kg] - real, parameter :: rh2oocp = rh2o / cp ! Rv/cp [ ----] real, parameter :: toodry = 1.e-8 ! Minimum acceptable mixing ratio. [ kg/kg] real, parameter :: toowet = 3.e-2 ! Maximum acceptable mixing ratio. [ kg/kg] !---------------------------------------------------------------------------------------! @@ -161,7 +196,6 @@ Module rconstants real, parameter :: wdns = 1.000e3 ! Liquid water density [ kg/m³] real, parameter :: wdnsi = 1./wdns ! Inverse of liquid water density [ m³/kg] real, parameter :: cliq = 4.186e3 ! Liquid water specific heat (Cl) [ J/kg/K] - real, parameter :: cliqvlme = wdns*cliq ! Water heat capacity × water dens. [ J/m³/K] real, parameter :: cliqi = 1./cliq ! Inverse of water heat capacity [ kg K/J] !---------------------------------------------------------------------------------------! @@ -175,7 +209,6 @@ Module rconstants real, parameter :: fdns = 2.000e2 ! Frost density [ kg/m³] real, parameter :: fdnsi = 1./fdns ! Inverse of frost density [ m³/kg] real, parameter :: cice = 2.093e3 ! Ice specific heat (Ci) [ J/kg/K] - real, parameter :: cicevlme = wdns * cice ! Heat capacity × water density [ J/m³/K] real, parameter :: cicei = 1. / cice ! Inverse of ice heat capacity [ kg K/J] !---------------------------------------------------------------------------------------! @@ -184,40 +217,50 @@ Module rconstants !---------------------------------------------------------------------------------------! ! Phase change properties ! !---------------------------------------------------------------------------------------! - real, parameter :: t3ple = 273.16 ! Water triple point temp. (T3) [ K] - real, parameter :: t3plei = 1./t3ple ! 1./T3 [ 1/K] - real, parameter :: es3ple = 611.65685464 ! Vapour pressure at T3 (es3) [ Pa] - real, parameter :: es3plei = 1./es3ple ! 1./es3 [ 1/Pa] - real, parameter :: epes3ple = ep * es3ple ! epsilon × es3 [ Pa kg/kg] - real, parameter :: rh2ot3ple = rh2o * t3ple ! Rv × T3 [ J/kg] - real, parameter :: alvl = 2.50e6 ! Lat. heat - vaporisation (Lv) [ J/kg] - real, parameter :: alvi = 2.834e6 ! Lat. heat - sublimation (Ls) [ J/kg] - real, parameter :: alli = 3.34e5 ! Lat. heat - fusion (Lf) [ J/kg] - real, parameter :: allivlme = wdns * alli ! Lat. heat × water density [ J/m³] - real, parameter :: alvl2 = alvl * alvl ! Lv² [ J²/kg²] - real, parameter :: alvi2 = alvi * alvi ! Ls² [ J²/kg²] - real, parameter :: allii = 1. / alli ! 1./Lf [ kg/J] - real, parameter :: aklv = alvl / cp ! Lv/Cp [ K] - real, parameter :: akiv = alvi / cp ! Ls/Cp [ K] - real, parameter :: lvordry = alvl / rdry ! Lv/Ra [ K] - real, parameter :: lvorvap = alvl / rh2o ! Lv/Rv [ K] - real, parameter :: lsorvap = alvi / rh2o ! Ls/Rv [ K] - real, parameter :: lvt3ple = alvl * t3ple ! Lv × T3 [ K J/kg] - real, parameter :: lst3ple = alvi * t3ple ! Ls × T3 [ K J/kg] - real, parameter :: qicet3 = cice * t3ple ! q at triple point, only ice [ J/kg] - real, parameter :: qliqt3 = qicet3 + alli ! q at triple point, only liq. [ J/kg] - !---------------------------------------------------------------------------------------! - - - - !---------------------------------------------------------------------------------------! - ! Tsupercool is the temperature of supercooled water that will cause the energy to ! - ! be the same as ice at 0K. It can be used as an offset for temperature when defining ! - ! internal energy. The next two methods of defining the internal energy for the liquid ! - ! part: ! + real, parameter :: t3ple = 273.16 ! Water triple point temp. (T3)[ K] + real, parameter :: t3plei = 1./t3ple ! 1./T3 [ 1/K] + real, parameter :: es3ple = 611.65685464 ! Vapour pressure at T3 (es3) [ Pa] + real, parameter :: es3plei = 1./es3ple ! 1./es3 [ 1/Pa] + real, parameter :: epes3ple = ep * es3ple ! epsilon × es3 [ Pa kg/kg] + real, parameter :: rh2ot3ple = rh2o * t3ple ! Rv × T3 [ J/kg] + real, parameter :: alli = 3.34e5 ! Lat. heat - fusion (Lf)[ J/kg] + real, parameter :: alvl3 = 2.50e6 ! Lat. heat - vaporisation (Lv)[ J/kg] + real, parameter :: alvi3 = alli + alvl3 ! Lat. heat - sublimation (Ls)[ J/kg] + real, parameter :: allii = 1. / alli ! 1./Lf [ kg/J] + real, parameter :: aklv = alvl3 / cpdry ! Lv/Cp [ K] + real, parameter :: akiv = alvi3 / cpdry ! Ls/Cp [ K] + real, parameter :: lvordry = alvl3 / rdry ! Lv/Ra [ K] + real, parameter :: lvorvap = alvl3 / rh2o ! Lv/Rv [ K] + real, parameter :: lsorvap = alvi3 / rh2o ! Ls/Rv [ K] + real, parameter :: lvt3ple = alvl3 * t3ple ! Lv × T3 [ K J/kg] + real, parameter :: lst3ple = alvi3 * t3ple ! Ls × T3 [ K J/kg] + real, parameter :: uiicet3 = cice * t3ple ! u at triple point, only ice [ J/kg] + real, parameter :: uiliqt3 = uiicet3 + alli ! u at triple point, only liq. [ J/kg] + real, parameter :: dcpvl = cph2o - cliq ! difference of sp. heat [ J/kg/K] + real, parameter :: dcpvi = cph2o - cice ! difference of sp. heat [ J/kg/K] + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! The following variables are useful when defining the derivatives of theta_il. ! + ! They correspond to L?(T) - L?' T. ! + !---------------------------------------------------------------------------------------! + real, parameter :: del_alvl3 = alvl3 - dcpvl * t3ple + real, parameter :: del_alvi3 = alvi3 - dcpvi * t3ple + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! Tsupercool are defined as temperatures of supercooled liquid water (water vapour) ! + ! that will cause the internal energy (enthalpy) to be the same as ice at 0K. It can ! + ! be used as an offset for temperature when defining internal energy (enthalpy). The ! + ! next two methods of defining the internal energy for the liquid part: ! + ! ! + ! Uliq = Mliq [ Cice T3 + Cliq (T - T3) + Lf] ! + ! Uliq = Mliq Cliq (T - Tsupercool_liq) ! ! ! - ! Uliq = Mliq × [ Cice × T3 + Cliq × (T - T3) + Lf] ! - ! Uliq = Mliq × Cliq × (T - Tsupercool) ! + ! H = Mliq [ Cice T3 + Cliq (Ts - T3) + Lv3 + (Cpv - Cliq) (Ts-T3) + Cpv (T-T3) ] ! + ! H = Mliq Cpv (T - Tsupercool_vap) ] ! ! ! ! You may be asking yourself why would we have the ice term in the internal energy ! ! definition. The reason is that we can think that internal energy is the amount of ! @@ -225,20 +268,8 @@ Module rconstants ! prefer the inverse way, Uliq is the amount of energy the parcel would need to lose to ! ! become solid at 0K.) ! !---------------------------------------------------------------------------------------! - real, parameter :: tsupercool = t3ple - (qicet3+alli) * cliqi - !---------------------------------------------------------------------------------------! - - - - !---------------------------------------------------------------------------------------! - ! eta3ple is a constant related to the triple point that is used to find enthalpy ! - ! when the equilibrium temperature is above t3ple. cimcp (clmcp) is the difference ! - ! between the heat capacity of ice (liquid) and vapour, the latter assumed to be the ! - ! same as the dry air, for simplicity. ! - !---------------------------------------------------------------------------------------! - real, parameter :: eta3ple = (cice - cliq) * t3ple + alvi - real, parameter :: cimcp = cice - cp - real, parameter :: clmcp = cliq - cp + real, parameter :: tsupercool_liq = t3ple - (uiicet3 + alli ) * cliqi + real, parameter :: tsupercool_vap = t3ple - (uiicet3 + alvi3) * cph2oi !---------------------------------------------------------------------------------------! @@ -252,9 +283,9 @@ Module rconstants ! ature as a thermodynamic variable in deep atmospheric models. Mon. Wea. Rev., ! ! v. 109, 1094-1102. ! !---------------------------------------------------------------------------------------! - real, parameter :: ttripoli = 253. ! "Tripoli-Cotton" temp. (Ttr) [ K] - real, parameter :: htripoli = cp*ttripoli ! Sensible enthalpy at T=Ttr [ J/kg] - real, parameter :: htripolii = 1./htripoli ! 1./htripoli [ kg/J] + real, parameter :: ttripoli = 253. ! "Tripoli-Cotton" temp. (Ttr) [ K] + real, parameter :: htripoli = cpdry*ttripoli ! Sensible enthalpy at T=Ttr [ J/kg] + real, parameter :: htripolii = 1./htripoli ! 1./htripoli [ kg/J] !---------------------------------------------------------------------------------------! @@ -272,6 +303,27 @@ Module rconstants + !---------------------------------------------------------------------------------------! + ! These are the lower and upper bounds in which we compute exponentials. This is ! + ! to avoid overflows and/or underflows when we compute exponentials. ! + !---------------------------------------------------------------------------------------! + real, parameter :: lnexp_min = -38. + real, parameter :: lnexp_max = 38. + !---------------------------------------------------------------------------------------! + + + + !---------------------------------------------------------------------------------------! + ! These are the just default huge and tiny numbers that are not the actual huge or ! + ! tiny values from Fortran intrinsic functions, so if you do any numerical operations ! + ! you will still be fine. ! + !---------------------------------------------------------------------------------------! + real, parameter :: huge_num = 1.e+19 + real, parameter :: tiny_num = 1.e-19 + !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! ! Double precision version of all constants used in Runge-Kutta. ! !---------------------------------------------------------------------------------------! @@ -298,12 +350,15 @@ Module rconstants real(kind=8), parameter :: volmoll8 = dble(volmoll ) real(kind=8), parameter :: mmdry8 = dble(mmdry ) real(kind=8), parameter :: mmh2o8 = dble(mmh2o ) + real(kind=8), parameter :: mmo28 = dble(mmo2 ) + real(kind=8), parameter :: mmo38 = dble(mmo3 ) real(kind=8), parameter :: mmco28 = dble(mmco2 ) real(kind=8), parameter :: mmdoc8 = dble(mmdoc ) real(kind=8), parameter :: mmcod8 = dble(mmcod ) real(kind=8), parameter :: mmdry10008 = dble(mmdry1000 ) real(kind=8), parameter :: mmcod1em68 = dble(mmcod1em6 ) real(kind=8), parameter :: mmdryi8 = dble(mmdryi ) + real(kind=8), parameter :: mmh2oi8 = dble(mmh2oi ) real(kind=8), parameter :: mmco2i8 = dble(mmco2i ) real(kind=8), parameter :: yr_day8 = dble(yr_day ) real(kind=8), parameter :: day_sec8 = dble(day_sec ) @@ -320,16 +375,19 @@ Module rconstants real(kind=8), parameter :: p00ki8 = dble(p00ki ) real(kind=8), parameter :: rdry8 = dble(rdry ) real(kind=8), parameter :: rdryi8 = dble(rdryi ) - real(kind=8), parameter :: cp8 = dble(cp ) - real(kind=8), parameter :: cv8 = dble(cv ) + real(kind=8), parameter :: cpdry8 = dble(cpdry ) + real(kind=8), parameter :: cvdry8 = dble(cvdry ) real(kind=8), parameter :: cpog8 = dble(cpog ) real(kind=8), parameter :: rocp8 = dble(rocp ) real(kind=8), parameter :: rocv8 = dble(rocv ) real(kind=8), parameter :: cpocv8 = dble(cpocv ) real(kind=8), parameter :: cpor8 = dble(cpor ) - real(kind=8), parameter :: cpi8 = dble(cpi ) - real(kind=8), parameter :: cpi48 = dble(cpi4 ) + real(kind=8), parameter :: cpdryi8 = dble(cpdryi ) + real(kind=8), parameter :: cpdryi48 = dble(cpdryi4 ) real(kind=8), parameter :: rh2o8 = dble(rh2o ) + real(kind=8), parameter :: cph2o8 = dble(cph2o ) + real(kind=8), parameter :: cph2oi8 = dble(cph2oi ) + real(kind=8), parameter :: cvh2o8 = dble(cvh2o ) real(kind=8), parameter :: gorh2o8 = dble(gorh2o ) real(kind=8), parameter :: ep8 = dble(ep ) real(kind=8), parameter :: epi8 = dble(epi ) @@ -338,33 +396,32 @@ Module rconstants real(kind=8), parameter :: wdns8 = dble(wdns ) real(kind=8), parameter :: wdnsi8 = dble(wdnsi ) real(kind=8), parameter :: cliq8 = dble(cliq ) - real(kind=8), parameter :: cliqvlme8 = dble(cliqvlme ) real(kind=8), parameter :: cliqi8 = dble(cliqi ) real(kind=8), parameter :: idns8 = dble(idns ) real(kind=8), parameter :: idnsi8 = dble(idnsi ) real(kind=8), parameter :: fdns8 = dble(fdns ) real(kind=8), parameter :: fdnsi8 = dble(fdnsi ) real(kind=8), parameter :: cice8 = dble(cice ) - real(kind=8), parameter :: cicevlme8 = dble(cicevlme ) real(kind=8), parameter :: cicei8 = dble(cicei ) real(kind=8), parameter :: t3ple8 = dble(t3ple ) real(kind=8), parameter :: t3plei8 = dble(t3plei ) real(kind=8), parameter :: es3ple8 = dble(es3ple ) real(kind=8), parameter :: es3plei8 = dble(es3plei ) real(kind=8), parameter :: epes3ple8 = dble(epes3ple ) - real(kind=8), parameter :: alvl8 = dble(alvl ) - real(kind=8), parameter :: alvi8 = dble(alvi ) + real(kind=8), parameter :: alvl38 = dble(alvl3 ) + real(kind=8), parameter :: alvi38 = dble(alvi3 ) real(kind=8), parameter :: alli8 = dble(alli ) - real(kind=8), parameter :: allivlme8 = dble(allivlme ) real(kind=8), parameter :: allii8 = dble(allii ) real(kind=8), parameter :: akiv8 = dble(akiv ) real(kind=8), parameter :: aklv8 = dble(aklv ) - real(kind=8), parameter :: qicet38 = dble(qicet3 ) - real(kind=8), parameter :: qliqt38 = dble(qliqt3 ) - real(kind=8), parameter :: tsupercool8 = dble(tsupercool ) - real(kind=8), parameter :: eta3ple8 = dble(eta3ple ) - real(kind=8), parameter :: cimcp8 = dble(cimcp ) - real(kind=8), parameter :: clmcp8 = dble(clmcp ) + real(kind=8), parameter :: uiicet38 = dble(uiicet3 ) + real(kind=8), parameter :: uiliqt38 = dble(uiliqt3 ) + real(kind=8), parameter :: dcpvl8 = dble(dcpvl ) + real(kind=8), parameter :: dcpvi8 = dble(dcpvi ) + real(kind=8), parameter :: del_alvl38 = dble(del_alvl3 ) + real(kind=8), parameter :: del_alvi38 = dble(del_alvi3 ) + real(kind=8), parameter :: tsupercool_liq8 = dble(tsupercool_liq) + real(kind=8), parameter :: tsupercool_vap8 = dble(tsupercool_vap) real(kind=8), parameter :: ttripoli8 = dble(ttripoli ) real(kind=8), parameter :: htripoli8 = dble(htripoli ) real(kind=8), parameter :: htripolii8 = dble(htripolii ) @@ -374,8 +431,21 @@ Module rconstants real(kind=8), parameter :: ltscalemax8 = dble(ltscalemax ) real(kind=8), parameter :: abswltlmin8 = dble(abswltlmin ) real(kind=8), parameter :: lturbmin8 = dble(lturbmin ) + real(kind=8), parameter :: th_diff8 = dble(th_diff ) + real(kind=8), parameter :: th_diffi8 = dble(th_diffi ) + real(kind=8), parameter :: kin_visc8 = dble(kin_visc ) + real(kind=8), parameter :: kin_visci8 = dble(kin_visci ) + real(kind=8), parameter :: th_expan8 = dble(th_expan ) + real(kind=8), parameter :: gr_coeff8 = dble(gr_coeff ) + real(kind=8), parameter :: lnexp_min8 = dble(lnexp_min ) + real(kind=8), parameter :: lnexp_max8 = dble(lnexp_max ) + real(kind=8), parameter :: huge_num8 = dble(huge_num ) + real(kind=8), parameter :: tiny_num8 = dble(tiny_num ) + real(kind=8), parameter :: euler_gam8 = dble(euler_gam ) !---------------------------------------------------------------------------------------! end module rconstants +!==========================================================================================! +!==========================================================================================! diff --git a/Ramspost/src/memory/rout_coms.f90 b/Ramspost/src/memory/rout_coms.f90 new file mode 100644 index 000000000..46cdb857c --- /dev/null +++ b/Ramspost/src/memory/rout_coms.f90 @@ -0,0 +1,223 @@ +!==========================================================================================! +!==========================================================================================! +! Module to allocate the output variables. ! +!------------------------------------------------------------------------------------------! +module rout_coms + + type rout_vars + real , pointer, dimension(:) :: abuff + real , pointer, dimension(:) :: bbuff + real , pointer, dimension(:,:) :: r2 + real , pointer, dimension(:,:,:) :: r3 + real , pointer, dimension(:,:,:,:) :: r6 + real , pointer, dimension(:,:,:) :: r7 + real , pointer, dimension(:,:,:,:) :: r8 + real , pointer, dimension(:,:,:) :: r9 + real , pointer, dimension(:,:,:) :: r10 + integer, pointer, dimension(:,:) :: iinf + integer, pointer, dimension(:,:) :: jinf + real , pointer, dimension(:,:,:) :: rmi + real , pointer, dimension(:,:) :: topo + real , pointer, dimension(:,:) :: exner + real , pointer, dimension(:,:) :: rlon + real , pointer, dimension(:,:) :: rlat + real , pointer, dimension(:,:,:) :: zplev + end type rout_vars + + type(rout_vars), allocatable, dimension(:) :: rout + type(rout_vars), allocatable, dimension(:) :: routgrads + + real , parameter :: maxnormal = 1.e+06 + real , parameter :: undefflg = -1.e+34 + + !=======================================================================================! + !=======================================================================================! + + + contains + + + + !=======================================================================================! + !=======================================================================================! + ! This routine allocates all buffers. ! + !---------------------------------------------------------------------------------------! + subroutine alloc_rout(this,nx,ny,nz,ngnd,npat,ncld,npl) + implicit none + !------ Arguments. ------------------------------------------------------------------! + type(rout_vars), intent(inout) :: this + integer , intent(in) :: nx + integer , intent(in) :: ny + integer , intent(in) :: nz + integer , intent(in) :: ngnd + integer , intent(in) :: npat + integer , intent(in) :: ncld + integer , intent(in) :: npl + !------ Local variables. ------------------------------------------------------------! + integer :: nbuff + !------------------------------------------------------------------------------------! + + + !----- Nullify all pointers. --------------------------------------------------------! + call nullify_rout(this) + !------------------------------------------------------------------------------------! + + + !----- Find the maximum memory to allocate the generic buffers. ---------------------! + nbuff = max(nx*ny*nz*ncld,nx*ny*nz*npat,nx*ny*ngnd*npat) + !------------------------------------------------------------------------------------! + + + !------------------------------------------------------------------------------------! + ! Then we can safely allocate them. ! + !------------------------------------------------------------------------------------! + allocate (this%abuff(nbuff) ) + allocate (this%bbuff(nbuff) ) + allocate (this%r2 (nx,ny) ) + allocate (this%r3 (nx,ny,nz ) ) + allocate (this%r6 (nx,ny,nz ,ncld)) + allocate (this%r7 (nx,ny,npat) ) + allocate (this%r8 (nx,ny,ngnd,npat)) + allocate (this%r9 (nx,ny,ncld) ) + allocate (this%r10 (nx,ny,ngnd) ) + allocate (this%iinf (nx,ny) ) + allocate (this%jinf (nx,ny) ) + allocate (this%rmi (nx,ny,4) ) + allocate (this%topo (nx,ny) ) + allocate (this%exner(nx,ny) ) + allocate (this%rlon (nx,ny) ) + allocate (this%rlat (nx,ny) ) + allocate (this%zplev(nx,ny,npl) ) + !------------------------------------------------------------------------------------! + + call undef_rout (this,.true.) + return + end subroutine alloc_rout + !=======================================================================================! + !=======================================================================================! + + + + + + !=======================================================================================! + !=======================================================================================! + ! This subroutine nullifies all pointers to ensure a safe allocation. ! + !---------------------------------------------------------------------------------------! + subroutine nullify_rout(this) + implicit none + !------ Arguments. ------------------------------------------------------------------! + type(rout_vars), intent(inout) :: this + !------------------------------------------------------------------------------------! + + + !------ Nullify everything. ---------------------------------------------------------! + nullify (this%abuff) + nullify (this%bbuff) + nullify (this%r2 ) + nullify (this%r3 ) + nullify (this%r6 ) + nullify (this%r7 ) + nullify (this%r8 ) + nullify (this%r9 ) + nullify (this%r10 ) + nullify (this%iinf ) + nullify (this%jinf ) + nullify (this%rmi ) + nullify (this%topo ) + nullify (this%exner) + nullify (this%rlon ) + nullify (this%rlat ) + nullify (this%zplev) + !------------------------------------------------------------------------------------! + + return + end subroutine nullify_rout + !=======================================================================================! + !=======================================================================================! + + + + + + !=======================================================================================! + !=======================================================================================! + ! This subroutine deallocates all pointers. ! + !---------------------------------------------------------------------------------------! + subroutine undef_rout(this,everything) + implicit none + !------ Arguments. ------------------------------------------------------------------! + type(rout_vars), intent(inout) :: this + logical , intent(in) :: everything + !------------------------------------------------------------------------------------! + + + !------ Nullify everything. ---------------------------------------------------------! + if (associated(this%abuff)) this%abuff = undefflg + if (associated(this%bbuff)) this%bbuff = undefflg + if (associated(this%r2 )) this%r2 = undefflg + if (associated(this%r3 )) this%r3 = undefflg + if (associated(this%r6 )) this%r6 = undefflg + if (associated(this%r7 )) this%r7 = undefflg + if (associated(this%r8 )) this%r8 = undefflg + if (associated(this%r9 )) this%r9 = undefflg + if (associated(this%r10 )) this%r10 = undefflg + if (everything) then + if (associated(this%iinf )) this%iinf = -1 + if (associated(this%jinf )) this%jinf = -1 + if (associated(this%rmi )) this%rmi = undefflg + if (associated(this%topo )) this%topo = undefflg + if (associated(this%exner)) this%exner = undefflg + if (associated(this%rlon )) this%rlon = undefflg + if (associated(this%rlat )) this%rlat = undefflg + if (associated(this%zplev)) this%zplev = undefflg + end if + !------------------------------------------------------------------------------------! + + return + end subroutine undef_rout + !=======================================================================================! + !=======================================================================================! + + + + + + !=======================================================================================! + !=======================================================================================! + ! This subroutine deallocates all pointers. ! + !---------------------------------------------------------------------------------------! + subroutine dealloc_rout(this) + implicit none + !------ Arguments. ------------------------------------------------------------------! + type(rout_vars), intent(inout) :: this + !------------------------------------------------------------------------------------! + + + !------ Nullify everything. ---------------------------------------------------------! + if (associated(this%abuff)) deallocate (this%abuff) + if (associated(this%bbuff)) deallocate (this%bbuff) + if (associated(this%r2 )) deallocate (this%r2 ) + if (associated(this%r3 )) deallocate (this%r3 ) + if (associated(this%r6 )) deallocate (this%r6 ) + if (associated(this%r7 )) deallocate (this%r7 ) + if (associated(this%r8 )) deallocate (this%r8 ) + if (associated(this%r9 )) deallocate (this%r9 ) + if (associated(this%r10 )) deallocate (this%r10 ) + if (associated(this%iinf )) deallocate (this%iinf ) + if (associated(this%jinf )) deallocate (this%jinf ) + if (associated(this%rmi )) deallocate (this%rmi ) + if (associated(this%topo )) deallocate (this%topo ) + if (associated(this%exner)) deallocate (this%exner) + if (associated(this%rlon )) deallocate (this%rlon ) + if (associated(this%rlat )) deallocate (this%rlat ) + if (associated(this%zplev)) deallocate (this%zplev) + !------------------------------------------------------------------------------------! + + return + end subroutine dealloc_rout + !=======================================================================================! + !=======================================================================================! +end module rout_coms +!==========================================================================================! +!==========================================================================================! diff --git a/Ramspost/src/memory/rpost_dims.f90 b/Ramspost/src/memory/rpost_dims.f90 index 2b41b9974..a4aeed6d3 100644 --- a/Ramspost/src/memory/rpost_dims.f90 +++ b/Ramspost/src/memory/rpost_dims.f90 @@ -14,7 +14,7 @@ module rpost_dims ! in x-direction integer, parameter :: nypmax=300 ! NYPMAX - Maximum number of points ! in y-direction - integer, parameter :: nzpmax=200 ! NZPMAX - Maximum number of points + integer, parameter :: nzpmax=100 ! NZPMAX - Maximum number of points ! in z-direction ! If you change nzpmax, also change nplmax ! at ramspost_A.f90 @@ -95,6 +95,13 @@ module rpost_dims integer, parameter :: nplmax = nzpmax !---------------------------------------------------------------------------------------! + + !---------------------------------------------------------------------------------------! + ! Set NZEPMAX to the largest of NZPMAX*MAXCLOUDS, NZGMAX*MAXPATCH. ! + !---------------------------------------------------------------------------------------! + integer, parameter :: nzepmax = max(nzpmax*maxclouds,nzgmax*maxpatch) + !---------------------------------------------------------------------------------------! + !---------------------------------------------------------------------------------------! ! GrADS maximum dimensions. Because of the projection from polar-stereographic to ! ! regular longitude/latitude, GrADS dimensions must exceed the maximum grid size for a ! @@ -105,6 +112,14 @@ module rpost_dims integer, parameter :: maxgy = ceiling(stfac * nypmax) !---------------------------------------------------------------------------------------! + + + !---------------------------------------------------------------------------------------! + ! Maximum number of variables. ! + !---------------------------------------------------------------------------------------! + integer, parameter :: maxvars = 256 + !---------------------------------------------------------------------------------------! + end module rpost_dims !==========================================================================================! !==========================================================================================! diff --git a/Ramspost/src/memory/somevars.f90 b/Ramspost/src/memory/somevars.f90 index a7b275fd0..7a5da435f 100644 --- a/Ramspost/src/memory/somevars.f90 +++ b/Ramspost/src/memory/somevars.f90 @@ -1,5 +1,6 @@ module somevars integer :: myngrids,myn1,myn2,myn3,myjdim,myihtran,mynbig,myistar,co2_on + integer :: myiyear1,myimonth1,myidate1,myitime1 integer, allocatable, dimension(:) :: mynnxp,mynnyp,mynnzp real , allocatable, dimension (:) :: myplatn,myplonn,mydeltaxn,mydeltayn,mydeltazn real , allocatable, dimension(:,:) :: mydzmn,mydztn diff --git a/Ramspost/src/utils/charutils.f90 b/Ramspost/src/utils/charutils.f90 index d5126c6aa..de5107a2d 100644 --- a/Ramspost/src/utils/charutils.f90 +++ b/Ramspost/src/utils/charutils.f90 @@ -379,3 +379,275 @@ subroutine rams_fltsort(ni,xnums,cstr) return end +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +subroutine tolower(word,dimword) +!------------------------------------------------------------------------------------------! +! Subroutine tolower ! +! ! +! This subroutine converts all common upper-case characters into lowercase. ! +!------------------------------------------------------------------------------------------! + implicit none +!----- Arguments --------------------------------------------------------------------------! + integer, intent(in) :: dimword + character(len=*), dimension(dimword), intent(inout) :: word +!----- Internal variables -----------------------------------------------------------------! + integer :: wmax,w,d +!------------------------------------------------------------------------------------------! + do d=1,dimword + wmax=len_trim(word(d)) + do w=1,wmax + select case(word(d)(w:w)) + case('A') + word(d)(w:w)='a' + case('B') + word(d)(w:w)='b' + case('C') + word(d)(w:w)='c' + case('D') + word(d)(w:w)='d' + case('E') + word(d)(w:w)='e' + case('F') + word(d)(w:w)='f' + case('G') + word(d)(w:w)='g' + case('H') + word(d)(w:w)='h' + case('I') + word(d)(w:w)='i' + case('J') + word(d)(w:w)='j' + case('K') + word(d)(w:w)='k' + case('L') + word(d)(w:w)='l' + case('M') + word(d)(w:w)='m' + case('N') + word(d)(w:w)='n' + case('O') + word(d)(w:w)='o' + case('P') + word(d)(w:w)='p' + case('Q') + word(d)(w:w)='q' + case('R') + word(d)(w:w)='r' + case('S') + word(d)(w:w)='s' + case('T') + word(d)(w:w)='t' + case('U') + word(d)(w:w)='u' + case('V') + word(d)(w:w)='v' + case('W') + word(d)(w:w)='w' + case('X') + word(d)(w:w)='x' + case('Y') + word(d)(w:w)='y' + case('Z') + word(d)(w:w)='z' + case('Á') + word(d)(w:w)='á' + case('É') + word(d)(w:w)='é' + case('Í') + word(d)(w:w)='í' + case('Ó') + word(d)(w:w)='ó' + case('Ú') + word(d)(w:w)='ú' + case('Ý') + word(d)(w:w)='ý' + case('À') + word(d)(w:w)='à' + case('È') + word(d)(w:w)='è' + case('Ì') + word(d)(w:w)='ì' + case('Ò') + word(d)(w:w)='ò' + case('Ù') + word(d)(w:w)='ù' + case('Â') + word(d)(w:w)='â' + case('Ê') + word(d)(w:w)='ê' + case('Î') + word(d)(w:w)='î' + case('Ô') + word(d)(w:w)='ô' + case('Û') + word(d)(w:w)='û' + case('Ä') + word(d)(w:w)='ä' + case('Ë') + word(d)(w:w)='ë' + case('Ï') + word(d)(w:w)='ï' + case('Ö') + word(d)(w:w)='ö' + case('Ü') + word(d)(w:w)='ü' + case('Ã') + word(d)(w:w)='ã' + case('Õ') + word(d)(w:w)='õ' + case('Ñ') + word(d)(w:w)='ñ' + case('Å') + word(d)(w:w)='å' + case('Ç') + word(d)(w:w)='ç' + end select + end do + end do + return +end subroutine tolower +!==========================================================================================! +!==========================================================================================! + + + + + + +!==========================================================================================! +!==========================================================================================! +! Subroutine tolower ! +! ! +! This subroutine converts all common upper-case characters into lowercase. ! +!------------------------------------------------------------------------------------------! +subroutine tolower_sca(word) + implicit none + !----- Arguments -----------------------------------------------------------------------! + character(len=*), intent(inout) :: word + !----- Internal variables --------------------------------------------------------------! + integer :: wmax + integer :: w + !---------------------------------------------------------------------------------------! + + wmax=len_trim(word) + do w=1,wmax + select case(word(w:w)) + case('A') + word(w:w)='a' + case('B') + word(w:w)='b' + case('C') + word(w:w)='c' + case('D') + word(w:w)='d' + case('E') + word(w:w)='e' + case('F') + word(w:w)='f' + case('G') + word(w:w)='g' + case('H') + word(w:w)='h' + case('I') + word(w:w)='i' + case('J') + word(w:w)='j' + case('K') + word(w:w)='k' + case('L') + word(w:w)='l' + case('M') + word(w:w)='m' + case('N') + word(w:w)='n' + case('O') + word(w:w)='o' + case('P') + word(w:w)='p' + case('Q') + word(w:w)='q' + case('R') + word(w:w)='r' + case('S') + word(w:w)='s' + case('T') + word(w:w)='t' + case('U') + word(w:w)='u' + case('V') + word(w:w)='v' + case('W') + word(w:w)='w' + case('X') + word(w:w)='x' + case('Y') + word(w:w)='y' + case('Z') + word(w:w)='z' + case('Á') + word(w:w)='á' + case('É') + word(w:w)='é' + case('Í') + word(w:w)='í' + case('Ó') + word(w:w)='ó' + case('Ú') + word(w:w)='ú' + case('Ý') + word(w:w)='ý' + case('À') + word(w:w)='à' + case('È') + word(w:w)='è' + case('Ì') + word(w:w)='ì' + case('Ò') + word(w:w)='ò' + case('Ù') + word(w:w)='ù' + case('Â') + word(w:w)='â' + case('Ê') + word(w:w)='ê' + case('Î') + word(w:w)='î' + case('Ô') + word(w:w)='ô' + case('Û') + word(w:w)='û' + case('Ä') + word(w:w)='ä' + case('Ë') + word(w:w)='ë' + case('Ï') + word(w:w)='ï' + case('Ö') + word(w:w)='ö' + case('Ü') + word(w:w)='ü' + case('Ã') + word(w:w)='ã' + case('Õ') + word(w:w)='õ' + case('Ñ') + word(w:w)='ñ' + case('Å') + word(w:w)='å' + case('Ç') + word(w:w)='ç' + end select + end do + return +end subroutine tolower_sca +!==========================================================================================! +!==========================================================================================!